-
Notifications
You must be signed in to change notification settings - Fork 21
/
ST_GHC.hs
67 lines (49 loc) · 1.85 KB
/
ST_GHC.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
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