gale client

root / CacheIO.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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193

module CacheIO(
    -- cacheIO
    CacheIO,
    cacheIO,
    cacheIOeq,
    newCacheIO,
    MonadIO(..),
    JVar,
    modifyJVar,
    readJVar,
    waitJVar,
    waitJVarEq,
    waitJVarBy,
    newJVar,
    Readable(..),
    Writable(..),
    Token,
    waitJVarToken,
    badToken,
    combineVal

    ) where


import Control.Applicative
import Control.Monad.Trans
import Control.Concurrent
import Control.Monad
import System.Mem.StableName
import Control.Exception
import System.IO.Unsafe(unsafePerformIO)
import Data.IORef
--import IOExts

newtype CacheIO a = CacheIO { unCacheIO :: (IO (a, [IO Bool])) }


newCacheIO :: CacheIO a -> IO (IO a)
newCacheIO (CacheIO c) =  newMVar  (undefined, return False) >>= \mv -> return $ modifyMVar mv $ \z@(x,dep) -> do
    up <- dep
    if up then return (z,x) else c >>= \(x,deps) -> return ((x, (foldl (liftM2 (&&)) (return True) deps)),x)


cacheIO :: IO a -> CacheIO a
cacheIO io = CacheIO $ do
    v <- io
    sn <- makeStableName $! v
    let cc = do
        v <- io
        sn' <- makeStableName $! v
        return $ sn == sn'
    return (v,[cc])


cacheIOeq :: Eq a => IO a -> CacheIO a
cacheIOeq io = CacheIO $ do
    v <- io
    let cc = do
        v' <- io
        return $ v == v'
    return (v,[cc])

instance Functor CacheIO where
    fmap = liftM

instance Applicative CacheIO where
    pure = return
    (<*>) = ap

instance Monad CacheIO where
    {-# INLINE (>>=) #-}
    {-# INLINE return #-}
    CacheIO a >>= b = CacheIO $ a >>= \(x,cv) -> unCacheIO (b x) >>= \(y,cv') -> return  (y,cv ++ cv')
    return a = CacheIO (return (a, []))

instance MonadIO CacheIO where
    {-# INLINE liftIO #-}
    liftIO a = CacheIO $ a >>= \x -> return (x,[])


newtype JVar a = JVar (MVar (a,[MVar ()]))
newtype Token a = Token (StableName a)

newJVar :: a -> IO (JVar a)
newJVar x = do
    mv <- newMVar (x,[])
    return $ JVar mv

modifyJVar :: JVar a -> (a -> IO (a,b)) -> IO b
modifyJVar (JVar mv) action = modifyMVar mv $ \(v,ws) -> do
    (nv, r) <- action v
    mapM_ (flip putMVar ()) ws
    return ((nv,[]),r)

readJVar :: JVar a -> IO a
readJVar (JVar mv) = readMVar mv >>= \(x,_) -> return x

badToken :: Token a
badToken = Token $ unsafePerformIO $ makeStableName myUndefined where
    myUndefined = myUndefined

waitJVarToken :: JVar a -> Token a -> IO (a,Token a)
waitJVarToken = undefined

waitJVarEq :: Eq a => JVar a -> a -> IO a
waitJVarEq = waitJVarBy (==)

waitJVarBy :: (a -> a -> Bool) -> JVar a -> a -> IO a
waitJVarBy eq jv@(JVar mv) a = do
    rv <- modifyMVar mv $ \v@(b,ws) -> if a `eq` b then do
            w <- newEmptyMVar
            return ((b,w:ws),Left w)
        else return (v,Right b)
    case rv of
        (Left w) -> takeMVar w >>= \() -> waitJVarBy eq jv a
        (Right v) -> return v


waitJVar :: JVar a -> a -> IO a
waitJVar jv@(JVar mv) a = do
    rv <- modifyMVar mv $ \v@(b,ws) -> do
        an <- makeStableName $! a
        bn <- makeStableName $! b
        if an == bn then do
            w <- newEmptyMVar
            return ((b,w:ws),Left w)
         else return (v,Right b)
    case rv of
        (Left w) -> takeMVar w >>= \() -> waitJVar  jv a
        (Right v) -> return v

instance Readable JVar where
    readVal x = liftIO $ readJVar x

instance Writable JVar where
    modifyVal a b = liftIO $ modifyJVar a b

instance Readable MVar where
    readVal x = liftIO $ readMVar x
instance Writable MVar where
    modifyVal a b = liftIO $ modifyMVar a b

class Readable c where
    readVal :: MonadIO m => c a -> m a

newtype ArbitraryReader a = ArbitraryReader (IO a)

instance Readable ArbitraryReader where
    readVal (ArbitraryReader x) = liftIO x

combineVal :: (Readable c1,Readable c2) => c1 a -> c2 b -> IO (ArbitraryReader (a,b))
combineVal sva svb = do
    let lsv = do
        av <- readVal sva
        bv <- readVal svb
        return (av,bv)
    return $ ArbitraryReader lsv

instance Readable IO where
    readVal = liftIO

class Readable c => Writable c where
    writeVal :: MonadIO m => c a -> a -> m ()
    swapVal :: MonadIO m => c a -> a -> m a
    modifyVal :: MonadIO m => c a -> (a -> IO (a,b)) -> m b
    modifyVal_ :: MonadIO m => c a -> (a -> IO a) -> m ()
    mapVal :: MonadIO m => c a -> (a -> a) -> m ()

    writeVal v x = swapVal v x >> return ()
    swapVal v x = modifyVal v $ \y -> return (x,y)
    modifyVal_ v action = modifyVal v $ \y -> action y >>= \x -> return (x,())
    mapVal v f = modifyVal_ v (return . f)


newtype StrictVar v a = StrictVar (v a)

instance Readable v => Readable (StrictVar v) where
    readVal (StrictVar  mv) = readVal mv

instance Writable v => Writable (StrictVar v) where
    modifyVal (StrictVar mv) f = modifyVal mv (\x -> f x >>= \(nx,r) -> evaluate nx >>= \nnx -> return (nnx,r))


instance Readable IORef where
    readVal x = liftIO $ readIORef x

instance Writable IORef where
    modifyVal ior f = liftIO $ do
        v <- readIORef ior
        (nv,r) <- f v
        writeIORef ior nv
        return r