mergeless 0.2.0.2 → 0.3.0.0

raw patch · 5 files changed

+271/−250 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• mergeless.cabal +4/−3
• src/Data/Mergeless.hs +3/−2
• src/Data/Mergeless/Collection.hs +240/−233
• src/Data/Mergeless/Item.hs +12/−12

@@ -2,6 +2,18 @@  ## Unreleased changes +## [0.3.0.0] - 2020-05-21++### Added++* mergeSyncResponseCustom+* emptySyncResponse: in case you want to do the sync response creation yourself++### Changed++* Another parameter: the ClientId, so that you can use an sqlid as your client id+  This likely means that none of your code from mergeless-0.2 still compiles but it's easy to fix.+ ## [0.2.0.1] - 2020-02-13  * Fixed the benchmarks

@@ -4,16 +4,16 @@ -- -- see: https://github.com/sol/hpack ----- hash: 1f6863bf51a407e32135695c2be4fd727c6474cfe30e5543ca7974cf89827b54+-- hash: 5f5e451a78c312ccbef6cc567464e0983bc9a8fbba6a7f428016c9f186aeebcb  name:           mergeless-version:        0.2.0.2+version:        0.3.0.0 description:    Please see the README on GitHub at <https://github.com/NorfairKing/mergeless#readme> homepage:       https://github.com/NorfairKing/mergeless#readme bug-reports:    https://github.com/NorfairKing/mergeless/issues author:         Tom Sydney Kerckhove maintainer:     syd.kerckhove@gmail.com-copyright:      Copyright: (c) 2018 Tom Sydney Kerckhove+copyright:      Copyright: (c) 2018-2020 Tom Sydney Kerckhove license:        MIT build-type:     Simple extra-source-files:@@ -33,6 +33,7 @@       Paths_mergeless   hs-source-dirs:       src+  ghc-options: -Wall -fwarn-redundant-constraints   build-depends:       aeson     , base >=4.11 && <5

@@ -1,5 +1,6 @@ module Data.Mergeless-  ( module Data.Mergeless.Collection-  ) where+  ( module Data.Mergeless.Collection,+  )+where  import Data.Mergeless.Collection

@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -11,9 +12,10 @@ -- -- * Items must be immutable. -- * Items must allow for a centrally unique identifier.--- * Identifiers for items must be generatable in such a way that they are certainly unique.+-- * Items must allow for a client-side unique identifier.+-- * Identifiers for items must be generated in such a way that they are certainly unique. ----- Should mutation be a requirement, then it can be build such that it entails deleting the old version and creating a new version that is the modification of the old version.+-- Should mutation be a requirement, then there is another library: 'mergeful' for exactly this purpose. -- -- -- There are a few obvious candidates for identifiers:@@ -42,113 +44,125 @@ -- * The client sends that request to the central server and gets a 'SyncResponse'. -- * The client then updates its local store with 'mergeSyncResponse'. module Data.Mergeless.Collection-  ( ClientId(..)-  , ClientStore(..)-  , emptyClientStore-  , storeSize-  , addItemToClientStore-  , deleteUnsyncedFromClientStore-  , deleteSyncedFromClientStore-  , SyncRequest(..)-  , SyncResponse(..)-  , emptySyncResponse+  ( ClientStore (..),+    SyncRequest (..),+    SyncResponse (..),+     -- * Client-side Synchronisation-  , makeSyncRequest-  , mergeSyncResponse-  , addRemotelyAddedItems-  , addAddedItems-  , deleteItemsToBeDeletedLocally-  , deleteLocalUndeletedItems++    -- ** General+    ClientSyncProcessor (..),+    mergeSyncResponseCustom,++    -- ** Pure+    emptyClientStore,+    ClientId (..),+    storeSize,+    addItemToClientStore,+    deleteUnsyncedFromClientStore,+    deleteSyncedFromClientStore,+    emptySyncRequest,+    makeSyncRequest,+    mergeSyncResponse,+    pureClientSyncProcessor,+     -- * Server-side Synchronisation-    -- ** General synchronisation-  , ServerSyncProcessor(..)-  , processServerSyncCustom-    -- ** Synchronisation with a simple central store-  , ServerStore(..)-  , emptyServerStore-  , processServerSync-  ) where -import GHC.Generics (Generic)+    -- ** General synchronisation+    ServerSyncProcessor (..),+    processServerSyncCustom, -import Data.Validity-import Data.Validity.Containers ()+    -- ** Synchronisation with a simple central store+    ServerStore (..),+    emptyServerStore,+    emptySyncResponse,+    processServerSync,+  )+where +import Control.DeepSeq+import Control.Monad.State.Strict import Data.Aeson import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Set (Set)+import Data.Validity+import Data.Validity.Containers () import Data.Word--import Control.DeepSeq-import Control.Monad.State.Strict+import GHC.Generics (Generic)  {-# ANN module ("HLint: ignore Use lambda-case" :: String) #-} --- | A Client-side identifier for items.+-- | A Client-side identifier for items for use with pure client stores -- -- These only need to be unique at the client.-newtype ClientId =-  ClientId-    { unClientId :: Word64-    }+newtype ClientId+  = ClientId+      { unClientId :: Word64+      }   deriving (Show, Eq, Ord, Enum, Bounded, Generic, ToJSON, ToJSONKey, FromJSON, FromJSONKey)  instance Validity ClientId  instance NFData ClientId --- | A client-side store of items with Id's of type @i@ and values of type @a@-data ClientStore i a =-  ClientStore-    { clientStoreAdded :: !(Map ClientId a)-    , clientStoreSynced :: !(Map i a)-    , clientStoreDeleted :: !(Set i)-    }+-- | A client-side store of items with Client Id's of type @ci@, Server Id's of type @i@ and values of type @a@+data ClientStore ci si a+  = ClientStore+      { clientStoreAdded :: !(Map ci a),+        clientStoreSynced :: !(Map si a),+        clientStoreDeleted :: !(Set si)+      }   deriving (Show, Eq, Ord, Generic) -instance (NFData i, NFData a) => NFData (ClientStore i a)+instance (NFData ci, NFData si, NFData a) => NFData (ClientStore ci si a) -instance (Validity i, Validity a, Show i, Show a, Ord i, Ord a) => Validity (ClientStore i a) where+instance (Validity ci, Validity si, Validity a, Show ci, Show si, Ord ci, Ord si) => Validity (ClientStore ci si a) where   validate cs@ClientStore {..} =     mconcat-      [ genericValidate cs-      , declare "the store items have distinct ids" $-        distinct $ M.keys clientStoreSynced ++ S.toList clientStoreDeleted+      [ genericValidate cs,+        declare "the store items have distinct ids"+          $ distinct+          $ M.keys clientStoreSynced ++ S.toList clientStoreDeleted       ] -instance (Ord i, FromJSON i, FromJSONKey i, FromJSON a) => FromJSON (ClientStore i a) where+instance (Ord ci, FromJSON ci, FromJSONKey ci, Ord si, FromJSON si, FromJSONKey si, FromJSON a) => FromJSON (ClientStore ci si a) where   parseJSON =     withObject "ClientStore" $ \o ->-      ClientStore <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty <*>-      o .:? "deleted" .!= S.empty+      ClientStore <$> o .:? "added" .!= M.empty <*> o .:? "synced" .!= M.empty+        <*> o .:? "deleted" .!= S.empty -instance (Ord i, ToJSON i, ToJSONKey i, ToJSON a) => ToJSON (ClientStore i a) where+instance (Ord ci, ToJSON ci, ToJSONKey ci, Ord si, ToJSON si, ToJSONKey si, ToJSON a) => ToJSON (ClientStore ci si a) where   toJSON ClientStore {..} =     object       ["added" .= clientStoreAdded, "synced" .= clientStoreSynced, "deleted" .= clientStoreDeleted] --- | The store with no items.-emptyClientStore :: ClientStore i a+-- | The client store with no items.+emptyClientStore :: ClientStore ci si a emptyClientStore =   ClientStore-    {clientStoreAdded = M.empty, clientStoreSynced = M.empty, clientStoreDeleted = S.empty}+    { clientStoreAdded = M.empty,+      clientStoreSynced = M.empty,+      clientStoreDeleted = S.empty+    }  -- | The number of items in a store -- -- This does not count the deleted items, so that those really look deleted.-storeSize :: ClientStore i a -> Int+storeSize :: ClientStore ci si a -> Int storeSize ClientStore {..} = M.size clientStoreAdded + M.size clientStoreSynced -clientStoreIds :: Ord i => ClientStore i a -> Set i+clientStoreIds :: Ord si => ClientStore ci si a -> Set si clientStoreIds ClientStore {..} = M.keysSet clientStoreSynced `S.union` clientStoreDeleted  -- | Add an item to a client store as an added item. ----- This will take care of the uniqueness constraint of the 'ClientId's in the map.-addItemToClientStore :: (Ord i, Ord a) => a -> ClientStore i a -> ClientStore i a+-- This will take care of the uniqueness constraint of the 'ci's in the map.+--+-- The values wrap around when reaching 'maxBound'.+addItemToClientStore :: (Enum ci, Bounded ci, Ord ci) => a -> ClientStore ci si a -> ClientStore ci si a addItemToClientStore a cs =   let oldAddedItems = clientStoreAdded cs       newAddedItems =@@ -159,276 +173,269 @@ -- | Find a free client id to use -- -- You shouldn't need this function, 'addItemToClientStore' takes care of this.-findFreeSpot :: Map ClientId a -> ClientId+--+-- The values wrap around when reaching 'maxBound'.+findFreeSpot :: (Ord ci, Enum ci, Bounded ci) => Map ci a -> ci findFreeSpot m =   if M.null m-    then ClientId 0-    else let (i, _) = M.findMax m-          in go (next i)+    then minBound+    else+      let (i, _) = M.findMax m+       in go (next i)   where     go i =       if M.member i m         then go (next i)         else i-    next (ClientId w)-      | w == maxBound = ClientId 0-      | otherwise = ClientId $ succ w+    next ci+      | ci == maxBound = minBound+      | otherwise = succ ci -deleteUnsyncedFromClientStore :: (Ord i, Ord a) => ClientId -> ClientStore i a -> ClientStore i a+deleteUnsyncedFromClientStore :: Ord ci => ci -> ClientStore ci si a -> ClientStore ci si a deleteUnsyncedFromClientStore cid cs = cs {clientStoreAdded = M.delete cid $ clientStoreAdded cs} -deleteSyncedFromClientStore :: (Ord i, Ord a) => i -> ClientStore i a -> ClientStore i a+deleteSyncedFromClientStore :: Ord si => si -> ClientStore ci si a -> ClientStore ci si a deleteSyncedFromClientStore i cs =   let syncedBefore = clientStoreSynced cs    in case M.lookup i syncedBefore of         Nothing -> cs         Just _ ->           cs-            { clientStoreSynced = M.delete i syncedBefore-            , clientStoreDeleted = S.insert i $ clientStoreDeleted cs+            { clientStoreSynced = M.delete i syncedBefore,+              clientStoreDeleted = S.insert i $ clientStoreDeleted cs             } --- | A synchronisation request for items with identifiers of type @i@ and values of type @a@-data SyncRequest i a =-  SyncRequest-    { syncRequestAdded :: !(Map ClientId a)-    , syncRequestSynced :: !(Set i)-    , syncRequestDeleted :: !(Set i)-    }+-- | A synchronisation request for items with Client Id's of type @ci@, Server Id's of type @i@ and values of type @a@+data SyncRequest ci si a+  = SyncRequest+      { syncRequestAdded :: !(Map ci a),+        syncRequestSynced :: !(Set si),+        syncRequestDeleted :: !(Set si)+      }   deriving (Show, Eq, Ord, Generic) -instance (NFData i, NFData a) => NFData (SyncRequest i a)+instance (NFData ci, NFData si, NFData a) => NFData (SyncRequest ci si a) -instance (Validity i, Validity a, Ord i, Ord a) => Validity (SyncRequest i a) where+instance (Validity ci, Validity si, Validity a, Ord ci, Ord si, Show ci) => Validity (SyncRequest ci si a) where   validate sr@SyncRequest {..} =     mconcat-      [ genericValidate sr-      , declare "the sync request items have distinct ids" $-        distinct $ S.toList syncRequestSynced ++ S.toList syncRequestDeleted+      [ genericValidate sr,+        declare "the sync request items have distinct ids"+          $ distinct+          $ S.toList syncRequestSynced ++ S.toList syncRequestDeleted       ] -instance (FromJSON i, FromJSON a, Ord i, Ord a) => FromJSON (SyncRequest i a) where+instance (FromJSON ci, FromJSON si, FromJSON a, FromJSONKey ci, Ord ci, Ord si, Ord a) => FromJSON (SyncRequest ci si a) where   parseJSON =     withObject "SyncRequest" $ \o ->-      SyncRequest <$> o .: "added" <*> o .: "synced" <*> o .: "undeleted"+      SyncRequest <$> o .: "added" <*> o .: "synced" <*> o .: "deleted" -instance (ToJSON i, ToJSON a) => ToJSON (SyncRequest i a) where+instance (ToJSON ci, ToJSON si, ToJSON a, ToJSONKey ci) => ToJSON (SyncRequest ci si a) where   toJSON SyncRequest {..} =     object-      [ "added" .= syncRequestAdded-      , "synced" .= syncRequestSynced-      , "undeleted" .= syncRequestDeleted+      [ "added" .= syncRequestAdded,+        "synced" .= syncRequestSynced,+        "deleted" .= syncRequestDeleted       ] +emptySyncRequest :: SyncRequest ci si a+emptySyncRequest =+  SyncRequest+    { syncRequestAdded = M.empty,+      syncRequestSynced = S.empty,+      syncRequestDeleted = S.empty+    }+ -- | Produce a synchronisation request for a client-side store. -- -- This request can then be sent to a central store for synchronisation.-makeSyncRequest :: (Ord i, Ord a) => ClientStore i a -> SyncRequest i a+makeSyncRequest :: ClientStore ci si a -> SyncRequest ci si a makeSyncRequest ClientStore {..} =   SyncRequest-    { syncRequestAdded = clientStoreAdded-    , syncRequestSynced = M.keysSet clientStoreSynced-    , syncRequestDeleted = clientStoreDeleted+    { syncRequestAdded = clientStoreAdded,+      syncRequestSynced = M.keysSet clientStoreSynced,+      syncRequestDeleted = clientStoreDeleted     }  -- | A synchronisation response for items with identifiers of type @i@ and values of type @a@-data SyncResponse i a =-  SyncResponse-    { syncResponseClientAdded :: !(Map ClientId i)-    , syncResponseClientDeleted :: !(Set i)-    , syncResponseServerAdded :: !(Map i a)-    , syncResponseServerDeleted :: !(Set i)-    }+data SyncResponse ci si a+  = SyncResponse+      { syncResponseClientAdded :: !(Map ci si),+        syncResponseClientDeleted :: !(Set si),+        syncResponseServerAdded :: !(Map si a),+        syncResponseServerDeleted :: !(Set si)+      }   deriving (Show, Eq, Ord, Generic) -instance (NFData i, NFData a) => NFData (SyncResponse i a)+instance (NFData ci, NFData si, NFData a) => NFData (SyncResponse ci si a) -instance (Validity i, Validity a, Show i, Show a, Ord i, Ord a) => Validity (SyncResponse i a) where+instance (Validity ci, Validity si, Validity a, Show ci, Show si, Ord ci, Ord si) => Validity (SyncResponse ci si a) where   validate sr@SyncResponse {..} =     mconcat-      [ genericValidate sr-      , declare "the sync response items have distinct uuids" $-        distinct $-        concat-          [ M.elems syncResponseClientAdded-          , S.toList syncResponseClientDeleted-          , M.keys syncResponseServerAdded-          , S.toList syncResponseServerDeleted-          ]+      [ genericValidate sr,+        declare "the sync response items have distinct uuids"+          $ distinct+          $ concat+            [ M.elems syncResponseClientAdded,+              S.toList syncResponseClientDeleted,+              M.keys syncResponseServerAdded,+              S.toList syncResponseServerDeleted+            ]       ] -instance (Ord i, FromJSON i, FromJSONKey i, Ord a, FromJSON a) => FromJSON (SyncResponse i a) where+instance (Ord ci, Ord si, FromJSON ci, FromJSON si, FromJSONKey ci, FromJSONKey si, Ord a, FromJSON a) => FromJSON (SyncResponse ci si a) where   parseJSON =     withObject "SyncResponse" $ \o ->-      SyncResponse <$> o .: "client-added" <*> o .: "client-deleted" <*> o .: "server-added" <*>-      o .: "server-deleted"+      SyncResponse <$> o .: "client-added" <*> o .: "client-deleted" <*> o .: "server-added"+        <*> o+        .: "server-deleted" -instance (ToJSON i, ToJSONKey i, ToJSON a) => ToJSON (SyncResponse i a) where+instance (ToJSON ci, ToJSON si, ToJSONKey ci, ToJSONKey si, ToJSON a) => ToJSON (SyncResponse ci si a) where   toJSON SyncResponse {..} =     object-      [ "client-added" .= syncResponseClientAdded-      , "client-deleted" .= syncResponseClientDeleted-      , "server-added" .= syncResponseServerAdded-      , "server-deleted" .= syncResponseServerDeleted+      [ "client-added" .= syncResponseClientAdded,+        "client-deleted" .= syncResponseClientDeleted,+        "server-added" .= syncResponseServerAdded,+        "server-deleted" .= syncResponseServerDeleted       ] -emptySyncResponse :: SyncResponse i ia+emptySyncResponse :: SyncResponse ci si a emptySyncResponse =   SyncResponse-    { syncResponseClientAdded = M.empty-    , syncResponseClientDeleted = S.empty-    , syncResponseServerAdded = M.empty-    , syncResponseServerDeleted = S.empty+    { syncResponseClientAdded = M.empty,+      syncResponseClientDeleted = S.empty,+      syncResponseServerAdded = M.empty,+      syncResponseServerDeleted = S.empty     }  -- | Merge a synchronisation response back into a client-side store. mergeSyncResponse ::-     forall i a. (Ord i, Ord a)-  => ClientStore i a-  -> SyncResponse i a-  -> ClientStore i a-mergeSyncResponse s SyncResponse {..} =-  addRemotelyAddedItems syncResponseServerAdded .-  addAddedItems syncResponseClientAdded .-  deleteItemsToBeDeletedLocally syncResponseServerDeleted .-  deleteLocalUndeletedItems syncResponseClientDeleted $-  s--addRemotelyAddedItems :: (Ord i, Ord a) => Map i a -> ClientStore i a -> ClientStore i a-addRemotelyAddedItems m cs =-  cs {clientStoreSynced = M.union (clientStoreSynced cs) (m `diffSet` clientStoreIds cs)}+  forall ci si a.+  (Ord ci, Ord si) =>+  ClientStore ci si a ->+  SyncResponse ci si a ->+  ClientStore ci si a+mergeSyncResponse s sr =+  flip execState s $+    mergeSyncResponseCustom+      pureClientSyncProcessor+      sr -addAddedItems ::-     forall i a. (Ord i, Ord a)-  => Map ClientId i-  -> ClientStore i a-  -> ClientStore i a-addAddedItems addedItems cs =-  let oldAdded = clientStoreAdded cs-      oldSynced = clientStoreSynced cs-      go :: (Map ClientId a, Map i a) -> ClientId -> i -> (Map ClientId a, Map i a)-      go (added, synced) cid i =-        case M.lookup cid added of-          Nothing -> (added, synced)-          Just a -> (M.delete cid added, M.insert i a synced)-      (newAdded, newSynced) = M.foldlWithKey go (oldAdded, oldSynced) addedItems-   in cs {clientStoreAdded = newAdded, clientStoreSynced = newSynced}+pureClientSyncProcessor :: forall ci si a. (Ord ci, Ord si) => ClientSyncProcessor ci si a (State (ClientStore ci si a))+pureClientSyncProcessor =+  ClientSyncProcessor+    { clientSyncProcessorSyncServerAdded = \m -> modify $ \cs ->+        cs {clientStoreSynced = M.union (clientStoreSynced cs) (m `diffSet` clientStoreIds cs)},+      clientSyncProcessorSyncClientAdded = \addedItems -> modify $ \cs ->+        let oldAdded = clientStoreAdded cs+            oldSynced = clientStoreSynced cs+            go :: (Map ci a, Map si a) -> ci -> si -> (Map ci a, Map si a)+            go (added, synced) cid i =+              case M.lookup cid added of+                Nothing -> (added, synced)+                Just a -> (M.delete cid added, M.insert i a synced)+            (newAdded, newSynced) = M.foldlWithKey go (oldAdded, oldSynced) addedItems+         in cs {clientStoreAdded = newAdded, clientStoreSynced = newSynced},+      clientSyncProcessorSyncServerDeleted = \toBeDeletedLocally -> modify $ \cs ->+        cs {clientStoreSynced = clientStoreSynced cs `diffSet` toBeDeletedLocally},+      clientSyncProcessorSyncClientDeleted = \cd -> modify $ \cs ->+        cs {clientStoreDeleted = clientStoreDeleted cs `S.difference` cd}+    } -deleteItemsToBeDeletedLocally :: (Ord i, Ord a) => Set i -> ClientStore i a -> ClientStore i a-deleteItemsToBeDeletedLocally toBeDeletedLocally cs =-  cs {clientStoreSynced = clientStoreSynced cs `diffSet` toBeDeletedLocally}+data ClientSyncProcessor ci si a m+  = ClientSyncProcessor+      { clientSyncProcessorSyncServerAdded :: Map si a -> m (),+        clientSyncProcessorSyncClientAdded :: Map ci si -> m (),+        clientSyncProcessorSyncServerDeleted :: Set si -> m (),+        clientSyncProcessorSyncClientDeleted :: Set si -> m ()+      }+  deriving (Generic) -deleteLocalUndeletedItems :: (Ord i, Ord a) => Set i -> ClientStore i a -> ClientStore i a-deleteLocalUndeletedItems cd cs = cs {clientStoreDeleted = clientStoreDeleted cs `S.difference` cd}+mergeSyncResponseCustom :: Monad m => ClientSyncProcessor ci si a m -> SyncResponse ci si a -> m ()+mergeSyncResponseCustom ClientSyncProcessor {..} SyncResponse {..} = do+  -- The order here matters!+  clientSyncProcessorSyncServerAdded syncResponseServerAdded+  clientSyncProcessorSyncServerDeleted syncResponseServerDeleted+  clientSyncProcessorSyncClientDeleted syncResponseClientDeleted+  clientSyncProcessorSyncClientAdded syncResponseClientAdded  -- | A record of the basic operations that are necessary to build a synchronisation processor.-data ServerSyncProcessor i a m =-  ServerSyncProcessor-    { serverSyncProcessorDeleteMany :: Set i -> m (Set i)-      -- ^ Delete the items with an identifier in the given set, return the set that was indeed deleted or did not exist.-      -- In particular, return the identifiers of the items that the client should forget about.-    , serverSyncProcessorQueryNoLongerSynced :: Set i -> m (Set i) -- ^ Query the identifiers of the items that are in the given set but not in the store.-    , serverSyncProcessorQueryNewRemote :: Set i -> m (Map i a) -- ^ Query the items that are in store, but not in the given set.-    , serverSyncProcessorInsertMany :: Map ClientId a -> m (Map ClientId i) -- ^ Insert a set of items into the store.-    }+data ServerSyncProcessor ci si a m+  = ServerSyncProcessor+      { serverSyncProcessorRead :: m (Map si a),+        serverSyncProcessorAddItems :: Map ci a -> m (Map ci si),+        serverSyncProcessorDeleteItems :: Set si -> m (Set si)+      }   deriving (Generic) --- | Process a server-side synchronisation request using a custom synchronisation processor------ WARNING: The identifier generation function must produce newly unique identifiers such that each new item gets a unique identifier.------ You can use this function with deterministically-random identifiers or incrementing identifiers. processServerSyncCustom ::-     forall i a m. (Ord i, Ord a, Monad m)-  => ServerSyncProcessor i a m-  -> SyncRequest i a-  -> m (SyncResponse i a)+  forall ci si a m.+  (Ord si, Monad m) =>+  ServerSyncProcessor ci si a m ->+  SyncRequest ci si a ->+  m (SyncResponse ci si a) processServerSyncCustom ServerSyncProcessor {..} SyncRequest {..} = do-  deletedFromClient <- deleteUndeleted-        -- First we delete the items that were deleted locally but not yet remotely.-        -- Then we find the items that have been deleted remotely but not locally-  deletedRemotely <- syncItemsToBeDeletedLocally-        -- Then we find the items that have appeared remotely but aren't known locally-  newRemoteItems <- syncNewRemoteItems-        -- Then we add the items that should be added.-  newLocalItems <- syncAddedItems-  pure-    SyncResponse-      { syncResponseClientAdded = newLocalItems-      , syncResponseClientDeleted = deletedFromClient-      , syncResponseServerAdded = newRemoteItems-      , syncResponseServerDeleted = deletedRemotely-      }-  where-    deleteUndeleted :: m (Set i)-    deleteUndeleted = serverSyncProcessorDeleteMany syncRequestDeleted-    syncItemsToBeDeletedLocally :: m (Set i)-    syncItemsToBeDeletedLocally = serverSyncProcessorQueryNoLongerSynced syncRequestSynced-    syncNewRemoteItems :: m (Map i a)-    syncNewRemoteItems = serverSyncProcessorQueryNewRemote syncRequestSynced-    syncAddedItems :: m (Map ClientId i)-    syncAddedItems = serverSyncProcessorInsertMany syncRequestAdded+  serverItems <- serverSyncProcessorRead+  let syncResponseServerAdded = serverItems `M.difference` toMap (syncRequestSynced `S.union` syncRequestDeleted)+  let syncResponseServerDeleted = syncRequestSynced `S.difference` M.keysSet serverItems+  syncResponseClientDeleted <- serverSyncProcessorDeleteItems syncRequestDeleted+  syncResponseClientAdded <- serverSyncProcessorAddItems syncRequestAdded+  pure SyncResponse {..}  -- | A central store of items with identifiers of type @i@ and values of type @a@-newtype ServerStore i a =-  ServerStore-    { serverStoreItems :: Map i a-    }+newtype ServerStore si a+  = ServerStore+      { serverStoreItems :: Map si a+      }   deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) -instance (NFData i, NFData a) => NFData (ServerStore i a)+instance (NFData si, NFData a) => NFData (ServerStore si a) -instance (Validity i, Validity a, Show i, Show a, Ord i, Ord a) => Validity (ServerStore i a)+instance (Validity si, Validity a, Show si, Show a, Ord si) => Validity (ServerStore si a)  -- | An empty central store to start with-emptyServerStore :: ServerStore i a+emptyServerStore :: ServerStore si a emptyServerStore = ServerStore {serverStoreItems = M.empty} --- | Process a server-side synchronisation request using @getCurrentTime@+-- | Process a server-side synchronisation request using a server id generator -- -- see 'processSyncCustom' processServerSync ::-     forall m i a. (Ord i, Ord a, Monad m)-  => m i-  -> ServerStore i a-  -> SyncRequest i a-  -> m (SyncResponse i a, ServerStore i a)+  forall m ci si a.+  (Ord si, Monad m) =>+  m si ->+  ServerStore si a ->+  SyncRequest ci si a ->+  m (SyncResponse ci si a, ServerStore si a) processServerSync genUuid cs sr =   flip runStateT cs $-  processServerSyncCustom-    ServerSyncProcessor-      { serverSyncProcessorDeleteMany = deleteMany-      , serverSyncProcessorQueryNoLongerSynced = queryNoLongerSynced-      , serverSyncProcessorQueryNewRemote = queryNewRemote-      , serverSyncProcessorInsertMany = insertMany-      }-    sr+    processServerSyncCustom+      ServerSyncProcessor+        { serverSyncProcessorRead = gets serverStoreItems,+          serverSyncProcessorDeleteItems = deleteMany,+          serverSyncProcessorAddItems = insertMany+        }+      sr   where-    deleteMany :: Set i -> StateT (ServerStore i a) m (Set i)+    deleteMany :: Set si -> StateT (ServerStore si a) m (Set si)     deleteMany s = do       modC (`diffSet` s)       pure s-    queryNoLongerSynced :: Set i -> StateT (ServerStore i a) m (Set i)-    queryNoLongerSynced s = query ((s `S.difference`) . M.keysSet)-    queryNewRemote :: Set i -> StateT (ServerStore i a) m (Map i a)-    queryNewRemote s = query (`diffSet` s)-    query :: (Map i a -> b) -> StateT (ServerStore i a) m b-    query func = gets $ func . serverStoreItems-    insertMany :: Map ClientId a -> StateT (ServerStore i a) m (Map ClientId i)+    insertMany :: Map ci a -> StateT (ServerStore si a) m (Map ci si)     insertMany =       traverse $ \a -> do         u <- lift genUuid         ins u a         pure u-    ins :: i -> a -> StateT (ServerStore i a) m ()+    ins :: si -> a -> StateT (ServerStore si a) m ()     ins i val = modC $ M.insert i val-    modC :: (Map i a -> Map i a) -> StateT (ServerStore i a) m ()+    modC :: (Map si a -> Map si a) -> StateT (ServerStore si a) m ()     modC func = modify (\(ServerStore m) -> ServerStore $ func m) -diffSet :: Ord i => Map i a -> Set i -> Map i a+diffSet :: Ord si => Map si a -> Set si -> Map si a diffSet m s = m `M.difference` toMap s -toMap :: Set i -> Map i ()+toMap :: Set si -> Map si () toMap = M.fromSet (const ())  distinct :: Ord a => [a] -> Bool

@@ -117,32 +117,32 @@   case si of     ServerItemEmpty ->       case sr of-        ItemSyncRequestPoll+        ItemSyncRequestPoll ->           -- Both the client and the server think the item is empty, fine.-         -> (ItemSyncResponseInSyncEmpty, si)-        ItemSyncRequestNew a+          (ItemSyncResponseInSyncEmpty, si)+        ItemSyncRequestNew a ->           -- The client has a new item and the server has space for it, add it.-         -> (ItemSyncResponseClientAdded, ServerItemFull a)-        ItemSyncRequestKnown+          (ItemSyncResponseClientAdded, ServerItemFull a)+        ItemSyncRequestKnown ->           -- The client has an item that the server doesn't, so the server must have           -- deleted it when another client asked to do that.           -- Leave it deleted.-         -> (ItemSyncResponseServerDeleted, si)-        ItemSyncRequestDeleted+          (ItemSyncResponseServerDeleted, si)+        ItemSyncRequestDeleted ->           -- The server has deleted an item but the current client hasn't been made aware of that           -- AND this server also deleted that item in the meantime.           -- Just leave it deleted.-         -> (ItemSyncResponseClientDeleted, si)+          (ItemSyncResponseClientDeleted, si)     ServerItemFull s ->       case sr of-        ItemSyncRequestPoll+        ItemSyncRequestPoll ->           -- The server has an item that the client doesn't, send it to the client.-         -> (ItemSyncResponseServerAdded s, si)-        ItemSyncRequestNew _+          (ItemSyncResponseServerAdded s, si)+        ItemSyncRequestNew _ ->           -- The client wants to add an item that the server already has.           -- That means that another client has added that same item in the meantime.           -- This wouldn't happen if the items were named.           -- In this case, for completeness sake,-         -> (ItemSyncResponseServerAdded s, si)+          (ItemSyncResponseServerAdded s, si)         ItemSyncRequestKnown -> (ItemSyncResponseInSyncFull, si)         ItemSyncRequestDeleted -> (ItemSyncResponseClientDeleted, ServerItemEmpty)