-
Notifications
You must be signed in to change notification settings - Fork 57
/
HeterogeneousEnvironment.hs
84 lines (65 loc) · 2.82 KB
/
HeterogeneousEnvironment.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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
------------------------------------------------------------------------------
module Data.HeterogeneousEnvironment
( KeyGen
, HeterogeneousEnvironment
, Key
, newKeyGen
, empty
, makeKey
, lookup
, insert
, delete
, adjust
, getKeyId
) where
------------------------------------------------------------------------------
import Control.Monad
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.IORef
import GHC.Exts
import Prelude hiding (lookup)
import Unsafe.Coerce
------------------------------------------------------------------------------
data HeterogeneousEnvironment = HeterogeneousEnvironment (IntMap Any)
newtype Key a = Key Int
newtype KeyGen = KeyGen (IORef Int)
------------------------------------------------------------------------------
-- | If you use two different KeyGens to work with the same map, you deserve
-- what you get.
newKeyGen :: IO KeyGen
newKeyGen = liftM KeyGen $ newIORef 0
------------------------------------------------------------------------------
getKeyId :: Key a -> Int
getKeyId (Key x) = x
------------------------------------------------------------------------------
empty :: HeterogeneousEnvironment
empty = HeterogeneousEnvironment $ IM.empty
------------------------------------------------------------------------------
makeKey :: KeyGen -> IO (Key a)
makeKey (KeyGen gen) = do
k <- atomicModifyIORef gen nextKey
return $ Key k
where
nextKey !x = if x >= maxBound-1
then error "too many keys generated"
else let !x' = x+1 in (x',x)
------------------------------------------------------------------------------
lookup :: Key a -> HeterogeneousEnvironment -> Maybe a
lookup (Key k) (HeterogeneousEnvironment m) = fmap unsafeCoerce $ IM.lookup k m
------------------------------------------------------------------------------
insert :: Key a -> a -> HeterogeneousEnvironment -> HeterogeneousEnvironment
insert (Key k) v (HeterogeneousEnvironment m) = HeterogeneousEnvironment $
IM.insert k (unsafeCoerce v) m
------------------------------------------------------------------------------
delete :: Key a -> HeterogeneousEnvironment -> HeterogeneousEnvironment
delete (Key k) (HeterogeneousEnvironment m) = HeterogeneousEnvironment $
IM.delete k m
------------------------------------------------------------------------------
adjust :: (a -> a) -> Key a -> HeterogeneousEnvironment -> HeterogeneousEnvironment
adjust f (Key k) (HeterogeneousEnvironment m) = HeterogeneousEnvironment $
IM.adjust f' k m
where
f' = unsafeCoerce . f . unsafeCoerce