From 2f403246cb0eb4a0c39598f03cb2116ad00fc500 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Wed, 3 Jun 2026 20:32:11 +0200 Subject: Move Stored declaration to Object.Storable module --- erebos.cabal | 1 + src/Erebos/Network.hs | 1 + src/Erebos/Object/Internal.hs | 74 +---------------------------- src/Erebos/Storable.hs | 1 + src/Erebos/Storable/Internal.hs | 100 ++++++++++++++++++++++++++++++++++++++++ src/Erebos/Storage.hs | 1 + src/Erebos/Storage/Graph.hs | 2 +- src/Erebos/Storage/Head.hs | 2 +- src/Erebos/Storage/Internal.hs | 17 ------- src/Erebos/Storage/Key.hs | 4 +- src/Erebos/Storage/Merge.hs | 3 +- 11 files changed, 112 insertions(+), 94 deletions(-) create mode 100644 src/Erebos/Storable/Internal.hs diff --git a/erebos.cabal b/erebos.cabal index e45b824..da9e78d 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -124,6 +124,7 @@ library Erebos.Network.Channel Erebos.Network.Protocol Erebos.Object.Internal + Erebos.Storable.Internal Erebos.Storage.Disk Erebos.Storage.Internal Erebos.Storage.Memory diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs index 05717ef..7f0bbbf 100644 --- a/src/Erebos/Network.hs +++ b/src/Erebos/Network.hs @@ -73,6 +73,7 @@ import Erebos.Object.Internal import Erebos.PubKey import Erebos.Service import Erebos.State +import Erebos.Storable.Internal import Erebos.Storage import Erebos.Storage.Key import Erebos.Storage.Merge diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs index 799d185..5c81bf5 100644 --- a/src/Erebos/Object/Internal.hs +++ b/src/Erebos/Object/Internal.hs @@ -6,7 +6,8 @@ module Erebos.Object.Internal ( readRef, showRef, readRefDigest, showRefDigest, refDigestFromByteString, hashToRefDigest, - copyRef, partialRef, partialRefFromDigest, + copyRef, copyRef', partialRef, partialRefFromDigest, + zeroRef, Object, PartialObject, Object'(..), RecItem, RecItem'(..), @@ -15,9 +16,6 @@ module Erebos.Object.Internal ( ioLoadObject, ioLoadBytes, storeRawBytes, lazyLoadBytes, storeObject, - collectObjects, collectStoredObjects, - - MonadStorage(..), Storable(..), ZeroStorable(..), StorableText(..), StorableDate(..), StorableUUID(..), @@ -40,12 +38,6 @@ module Erebos.Object.Internal ( loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, loadMbRawWeak, loadTexts, loadBinaries, loadRefs, loadRawRefs, loadRawWeaks, loadZRef, - - Stored, - fromStored, storedRef, - wrappedStore, wrappedLoad, - copyStored, - unsafeMapStored, ) where import Control.Applicative @@ -69,8 +61,6 @@ import Data.Char import Data.Function import Data.Maybe import Data.Ratio -import Data.Set (Set) -import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding @@ -386,40 +376,10 @@ deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes (obj:) <$> deserializeObjects st rest -collectObjects :: Object -> [Object] -collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj) - -collectStoredObjects :: Stored Object -> [Stored Object] -collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored 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) - - deriving instance StorableUUID HeadID deriving instance StorableUUID HeadTypeID -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 - - class Storable a where store' :: a -> Store load' :: Load a @@ -812,36 +772,6 @@ loadRawWeaks name = mapMaybe p <$> loadRecItems p _ = Nothing - -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' - -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) - - showRatio :: Rational -> String showRatio r = case decimalRatio r of Just (n, 1) -> show n diff --git a/src/Erebos/Storable.hs b/src/Erebos/Storable.hs index 055309a..cd0d97d 100644 --- a/src/Erebos/Storable.hs +++ b/src/Erebos/Storable.hs @@ -43,3 +43,4 @@ module Erebos.Storable ( import Erebos.Error import Erebos.Object.Internal +import Erebos.Storable.Internal diff --git a/src/Erebos/Storable/Internal.hs b/src/Erebos/Storable/Internal.hs new file mode 100644 index 0000000..4ab48a5 --- /dev/null +++ b/src/Erebos/Storable/Internal.hs @@ -0,0 +1,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 diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs index f1cce84..d9559bc 100644 --- a/src/Erebos/Storage.hs +++ b/src/Erebos/Storage.hs @@ -24,6 +24,7 @@ module Erebos.Storage ( ) where import Erebos.Object.Internal +import Erebos.Storable.Internal import Erebos.Storage.Disk import Erebos.Storage.Head import Erebos.Storage.Memory diff --git a/src/Erebos/Storage/Graph.hs b/src/Erebos/Storage/Graph.hs index 79e25bc..1312941 100644 --- a/src/Erebos/Storage/Graph.hs +++ b/src/Erebos/Storage/Graph.hs @@ -40,7 +40,7 @@ import Data.Set qualified as S import System.IO.Unsafe (unsafePerformIO) import Erebos.Object -import Erebos.Storable +import Erebos.Storable.Internal import Erebos.Storage.Internal import Erebos.Util diff --git a/src/Erebos/Storage/Head.hs b/src/Erebos/Storage/Head.hs index 285902d..87212f0 100644 --- a/src/Erebos/Storage/Head.hs +++ b/src/Erebos/Storage/Head.hs @@ -30,7 +30,7 @@ import Data.Bifunctor import Data.Typeable import Erebos.Object -import Erebos.Storable +import Erebos.Storable.Internal import Erebos.Storage.Backend import Erebos.Storage.Internal import Erebos.UUID qualified as U diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs index 70a69b4..c7255ef 100644 --- a/src/Erebos/Storage/Internal.hs +++ b/src/Erebos/Storage/Internal.hs @@ -19,7 +19,6 @@ module Erebos.Storage.Internal ( Generation(..), HeadID(..), HeadTypeID(..), - Stored(..), storedStorage, ) where import Control.Arrow @@ -35,7 +34,6 @@ import Data.ByteArray qualified as BA import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL -import Data.Function import Data.HashTable.IO qualified as HT import Data.Hashable import Data.Kind @@ -238,21 +236,6 @@ newtype HeadID = HeadID UUID newtype HeadTypeID = HeadTypeID UUID deriving (Eq, Ord) -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') - -storedStorage :: Stored a -> Storage -storedStorage = refStorage . storedRef' - type Complete = Identity type Partial = Either RefDigest diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs index b615f16..85ebded 100644 --- a/src/Erebos/Storage/Key.hs +++ b/src/Erebos/Storage/Key.hs @@ -11,7 +11,9 @@ import Control.Monad.IO.Class import Data.ByteArray import Data.Typeable -import Erebos.Storable +import Erebos.Error +import Erebos.Object.Internal +import Erebos.Storable.Internal import Erebos.Storage.Internal class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where diff --git a/src/Erebos/Storage/Merge.hs b/src/Erebos/Storage/Merge.hs index 9de212f..ebb14bd 100644 --- a/src/Erebos/Storage/Merge.hs +++ b/src/Erebos/Storage/Merge.hs @@ -24,9 +24,8 @@ module Erebos.Storage.Merge ( import Data.Kind import Erebos.Object -import Erebos.Storable +import Erebos.Storable.Internal import Erebos.Storage.Graph -import Erebos.Storage.Internal class Storable (Component a) => Mergeable a where -- cgit v1.2.3