Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add module "Data.Unique.Really" that provides unique symbols that sur…

…vive GHCi reloads.
  • Loading branch information...
commit f70f16bdecaaae21fd04692b7298c7874080b7e6 1 parent 0d453b7
@HeinrichApfelmus authored
Showing with 95 additions and 18 deletions.
  1. +74 −0 src/Data/Unique/Really.hs
  2. +15 −17 src/Data/Vault/ST_GHC.hs
  3. +6 −1 vault.cabal
View
74 src/Data/Unique/Really.hs
@@ -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
View
32 src/Data/Vault/ST_GHC.hs
@@ -10,13 +10,17 @@ import qualified Data.IntMap as IntMap
import Data.IORef
import Control.Monad.ST
-import System.IO.Unsafe (unsafePerformIO)
+
+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
@@ -26,39 +30,33 @@ fromAny = unsafeCoerce
{-----------------------------------------------------------------------------
Vault
------------------------------------------------------------------------------}
-newtype Vault s = Vault (IntMap Any)
-newtype Key s a = Key Int
+newtype Vault s = Vault (Map Unique Any)
+newtype Key s a = Key Unique
empty :: Vault s
-empty = Vault IntMap.empty
-
-{-# NOINLINE nextKey #-}
-nextKey :: IORef (Key s a)
-nextKey = unsafePerformIO $ newIORef (Key 0)
+empty = Vault Map.empty
newKey :: ST s (Key s a)
-newKey = unsafeIOToST . atomicModifyIORef nextKey $ \k@(Key i) ->
- let k' = Key (i+1)
- in k' `seq` (k', k)
+newKey = unsafeIOToST $ Key <$> newUnique
lookup :: Key s a -> Vault s -> Maybe a
-lookup (Key k) (Vault m) = fromAny <$> IntMap.lookup k m
+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 $ IntMap.insert k (toAny x) m
+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 $ IntMap.adjust f' k m
+adjust f (Key k) (Vault m) = Vault $ Map.adjust f' k m
where f' = toAny . f . fromAny
-delete (Key k) (Vault m) = Vault $ IntMap.delete k m
+delete (Key k) (Vault m) = Vault $ Map.delete k m
-union (Vault m) (Vault m') = Vault $ IntMap.union m m'
+union (Vault m) (Vault m') = Vault $ Map.union m m'
{-----------------------------------------------------------------------------
Locker
------------------------------------------------------------------------------}
-data Locker s = Locker !Int Any
+data Locker s = Locker !Unique Any
lock :: Key s a -> a -> Locker s
lock (Key k) = Locker k . toAny
View
7 vault.cabal
@@ -31,11 +31,16 @@ source-repository head
Library
hs-source-dirs: src
build-depends: base == 4.*, containers == 0.4.*
+ 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.Vault.ST,
+ Data.Unique.Really
other-modules:
Data.Vault.ST_GHC,
Data.Vault.ST_Pure
Please sign in to comment.
Something went wrong with that request. Please try again.