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
|
module Erebos.Storable.Internal (
Storable(..), ZeroStorable(..),
StorableText(..), StorableDate(..), StorableUUID(..),
Stored(..),
fromStored, storedRef,
storedStorage,
wrappedStore, wrappedLoad,
copyStored,
unsafeMapStored,
collectObjects, collectStoredObjects,
MonadStorage(..),
) where
import Control.Monad.Reader
import Data.Function
import Data.Set (Set)
import Data.Set qualified as S
import Erebos.Storage.Internal
import Erebos.Object.Internal
data Stored a = Stored
{ storedRef' :: Ref
, storedObject' :: a
}
deriving (Show)
instance Eq (Stored a) where
(==) = (==) `on` (refDigest . storedRef')
instance Ord (Stored a) where
compare = compare `on` (refDigest . storedRef')
instance Storable a => Storable (Stored a) where
store st = copyRef st . storedRef
store' (Stored _ x) = store' x
load' = Stored <$> loadCurrentRef <*> load'
instance ZeroStorable a => ZeroStorable (Stored a) where
fromZero st = Stored (zeroRef st) $ fromZero st
fromStored :: Stored a -> a
fromStored = storedObject'
storedRef :: Stored a -> Ref
storedRef = storedRef'
storedStorage :: Stored a -> Storage
storedStorage = refStorage . storedRef'
wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a)
wrappedStore st x = do ref <- liftIO $ store st x
return $ Stored ref x
wrappedLoad :: Storable a => Ref -> Stored a
wrappedLoad ref = Stored ref (load ref)
copyStored :: forall m a. MonadIO m => Storage -> Stored a -> m (Stored a)
copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (\r -> Stored r x) <$> copyRef' st ref'
-- |Passed function needs to preserve the object representation to be safe
unsafeMapStored :: (a -> b) -> Stored a -> Stored b
unsafeMapStored f (Stored ref x) = Stored ref (f x)
collectStoredObjects :: Stored Object -> [ Stored Object ]
collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj)
collectObjects :: Object -> [Object]
collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj)
collectOtherStored :: Set RefDigest -> Object -> ( [ Stored Object ], Set RefDigest )
collectOtherStored seen (Rec items) = foldr helper ( [], seen ) $ map snd items
where helper (RecRef ref) (xs, s)
| r <- refDigest ref
, r `S.notMember` s
= let o = wrappedLoad ref
(xs', s') = collectOtherStored (S.insert r s) $ fromStored o
in ((o : xs') ++ xs, s')
helper _ ( xs, s ) = ( xs, s )
collectOtherStored seen _ = ( [], seen )
class Monad m => MonadStorage m where
getStorage :: m Storage
mstore :: Storable a => a -> m (Stored a)
default mstore :: MonadIO m => Storable a => a -> m (Stored a)
mstore x = do
st <- getStorage
wrappedStore st x
instance MonadIO m => MonadStorage (ReaderT Storage m) where
getStorage = ask
|