mergeless 0.3.0.0 → 0.4.0.0

raw patch · 5 files changed

+267/−118 lines, 5 filesdep +autodocodecdep +textPVP ok

version bump matches the API change (PVP)

Dependencies added: autodocodec, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−1
• README.md +0/−1
• mergeless.cabal +6/−5
• src/Data/Mergeless/Collection.hs +132/−96
• src/Data/Mergeless/Item.hs +120/−15

@@ -1,6 +1,14 @@ # Changelog for mergeless -## Unreleased changes+## [0.4.0.0] - 2022-06-19++### Added++* Autodocodec support++### Changed++* Made the json encoding of item sync types more sparse and forward-compatible.  ## [0.3.0.0] - 2020-05-21 

@@ -1,1 +0,0 @@-# mergeless

@@ -1,23 +1,22 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack ----- hash: 5f5e451a78c312ccbef6cc567464e0983bc9a8fbba6a7f428016c9f186aeebcb+-- hash: e31706648c86473e95cc860e1d3c9ca33a3e44055ecdd5c0136f1d68a0ab191f  name:           mergeless-version:        0.3.0.0+version:        0.4.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-2020 Tom Sydney Kerckhove+copyright:      Copyright: (c) 2018-2022 Tom Sydney Kerckhove license:        MIT build-type:     Simple extra-source-files:-    README.md     ChangeLog.md  source-repository head@@ -36,10 +35,12 @@   ghc-options: -Wall -fwarn-redundant-constraints   build-depends:       aeson+    , autodocodec     , base >=4.11 && <5     , containers     , deepseq     , mtl+    , text     , validity     , validity-containers   default-language: Haskell2010

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -80,14 +81,15 @@   ) where +import Autodocodec import Control.DeepSeq import Control.Monad.State.Strict-import Data.Aeson+import Data.Aeson (FromJSON, FromJSONKey (..), ToJSON, ToJSONKey (..)) 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 qualified Data.Set as S import Data.Validity import Data.Validity.Containers () import Data.Word@@ -98,24 +100,28 @@ -- | 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-      }-  deriving (Show, Eq, Ord, Enum, Bounded, Generic, ToJSON, ToJSONKey, FromJSON, FromJSONKey)+newtype ClientId = ClientId+  { unClientId :: Word64+  }+  deriving stock (Show, Eq, Ord, Generic)+  deriving newtype (Enum, Bounded, ToJSONKey, FromJSONKey)+  deriving (FromJSON, ToJSON) via (Autodocodec ClientId)  instance Validity ClientId  instance NFData ClientId +instance HasCodec ClientId where+  codec = dimapCodec ClientId unClientId codec <?> "ClientId"+ -- | 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)-      }+data ClientStore ci si a = ClientStore+  { clientStoreAdded :: !(Map ci a),+    clientStoreSynced :: !(Map si a),+    clientStoreDeleted :: !(Set si)+  }   deriving (Show, Eq, Ord, Generic)+  deriving (FromJSON, ToJSON) via (Autodocodec (ClientStore ci si a))  instance (NFData ci, NFData si, NFData a) => NFData (ClientStore ci si a) @@ -123,21 +129,30 @@   validate cs@ClientStore {..} =     mconcat       [ genericValidate cs,-        declare "the store items have distinct ids"-          $ distinct-          $ M.keys clientStoreSynced ++ S.toList clientStoreDeleted+        declare "the store items have distinct ids" $+          distinct $+            M.keys clientStoreSynced ++ S.toList clientStoreDeleted       ] -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--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]+instance+  ( Ord ci,+    FromJSONKey ci,+    ToJSONKey ci,+    Ord si,+    FromJSONKey si,+    ToJSONKey si,+    HasCodec si,+    Eq a,+    HasCodec a+  ) =>+  HasCodec (ClientStore ci si a)+  where+  codec =+    object "ClientStore" $+      ClientStore+        <$> optionalFieldWithOmittedDefault "added" M.empty "added items" .= clientStoreAdded+        <*> optionalFieldWithOmittedDefault "synced" M.empty "synced items" .= clientStoreSynced+        <*> optionalFieldWithOmittedDefault "deleted" S.empty "deleted items" .= clientStoreDeleted  -- | The client store with no items. emptyClientStore :: ClientStore ci si a@@ -206,13 +221,13 @@             }  -- | 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)+data SyncRequest ci si a = SyncRequest+  { syncRequestAdded :: !(Map ci a),+    syncRequestSynced :: !(Set si),+    syncRequestDeleted :: !(Set si)+  }+  deriving stock (Show, Eq, Ord, Generic)+  deriving (FromJSON, ToJSON) via (Autodocodec (SyncRequest ci si a))  instance (NFData ci, NFData si, NFData a) => NFData (SyncRequest ci si a) @@ -220,23 +235,30 @@   validate sr@SyncRequest {..} =     mconcat       [ genericValidate sr,-        declare "the sync request items have distinct ids"-          $ distinct-          $ S.toList syncRequestSynced ++ S.toList syncRequestDeleted+        declare "the sync request items have distinct ids" $+          distinct $+            S.toList syncRequestSynced ++ S.toList syncRequestDeleted       ] -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 .: "deleted"--instance (ToJSON ci, ToJSON si, ToJSON a, ToJSONKey ci) => ToJSON (SyncRequest ci si a) where-  toJSON SyncRequest {..} =-    object-      [ "added" .= syncRequestAdded,-        "synced" .= syncRequestSynced,-        "deleted" .= syncRequestDeleted-      ]+instance+  ( Ord ci,+    FromJSONKey ci,+    ToJSONKey ci,+    Ord si,+    FromJSONKey si,+    ToJSONKey si,+    HasCodec si,+    Eq a,+    HasCodec a+  ) =>+  HasCodec (SyncRequest ci si a)+  where+  codec =+    object "SyncRequest" $+      SyncRequest+        <$> optionalFieldWithOmittedDefault "added" M.empty "new items" .= syncRequestAdded+        <*> optionalFieldWithOmittedDefault "synced" S.empty "known items" .= syncRequestSynced+        <*> optionalFieldWithOmittedDefault "deleted" S.empty "deleted items" .= syncRequestDeleted  emptySyncRequest :: SyncRequest ci si a emptySyncRequest =@@ -258,14 +280,14 @@     }  -- | A synchronisation response for items with identifiers of type @i@ and values of type @a@-data SyncResponse ci si a-  = SyncResponse-      { syncResponseClientAdded :: !(Map ci si),-        syncResponseClientDeleted :: !(Set si),-        syncResponseServerAdded :: !(Map si a),-        syncResponseServerDeleted :: !(Set si)-      }+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)+  deriving (FromJSON, ToJSON) via (Autodocodec (SyncResponse ci si a))  instance (NFData ci, NFData si, NFData a) => NFData (SyncResponse ci si a) @@ -273,31 +295,37 @@   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-            ]+        declare "the sync response items have distinct uuids" $+          distinct $+            concat+              [ M.elems syncResponseClientAdded,+                S.toList syncResponseClientDeleted,+                M.keys syncResponseServerAdded,+                S.toList syncResponseServerDeleted+              ]       ] -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"--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-      ]+instance+  ( Ord ci,+    FromJSONKey ci,+    ToJSONKey ci,+    HasCodec ci,+    Ord si,+    FromJSONKey si,+    ToJSONKey si,+    HasCodec si,+    Eq a,+    HasCodec a+  ) =>+  HasCodec (SyncResponse ci si a)+  where+  codec =+    object "SyncResponse" $+      SyncResponse+        <$> optionalFieldWithOmittedDefault "client-added" M.empty "items added by the client" .= syncResponseClientAdded+        <*> optionalFieldWithOmittedDefault "client-deleted" S.empty "items deleted by the client" .= syncResponseClientDeleted+        <*> optionalFieldWithOmittedDefault "server-added" M.empty "items added by the server" .= syncResponseServerAdded+        <*> optionalFieldWithOmittedDefault "server-deleted" S.empty "items deleted by the server" .= syncResponseServerDeleted  emptySyncResponse :: SyncResponse ci si a emptySyncResponse =@@ -342,13 +370,12 @@         cs {clientStoreDeleted = clientStoreDeleted cs `S.difference` cd}     } -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 ()-      }+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)  mergeSyncResponseCustom :: Monad m => ClientSyncProcessor ci si a m -> SyncResponse ci si a -> m ()@@ -360,12 +387,11 @@   clientSyncProcessorSyncClientAdded syncResponseClientAdded  -- | A record of the basic operations that are necessary to build a synchronisation processor.-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)-      }+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)  processServerSyncCustom ::@@ -383,15 +409,25 @@   pure SyncResponse {..}  -- | A central store of items with identifiers of type @i@ and values of type @a@-newtype ServerStore si a-  = ServerStore-      { serverStoreItems :: Map si a-      }-  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)+newtype ServerStore si a = ServerStore+  { serverStoreItems :: Map si a+  }+  deriving (Show, Eq, Ord, Generic)+  deriving (FromJSON, ToJSON) via (Autodocodec (ServerStore si a))  instance (NFData si, NFData a) => NFData (ServerStore si a)  instance (Validity si, Validity a, Show si, Show a, Ord si) => Validity (ServerStore si a)++instance+  ( Ord si,+    FromJSONKey si,+    ToJSONKey si,+    HasCodec a+  ) =>+  HasCodec (ServerStore si a)+  where+  codec = dimapCodec ServerStore serverStoreItems codec  -- | An empty central store to start with emptyServerStore :: ServerStore si a

@@ -1,12 +1,16 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}  module Data.Mergeless.Item where +import Autodocodec import Control.DeepSeq-import Data.Aeson+import Data.Aeson (FromJSON, ToJSON)+import Data.Text (Text) import Data.Validity import Data.Validity.Containers () import GHC.Generics (Generic)@@ -18,32 +22,85 @@   | ClientAdded !a   | ClientSynced !a   | ClientDeleted-  deriving (Show, Eq, Ord, Generic)+  deriving stock (Show, Eq, Ord, Generic)+  deriving (FromJSON, ToJSON) via (Autodocodec (ClientItem a))  instance Validity a => Validity (ClientItem a)  instance NFData a => NFData (ClientItem a) -instance FromJSON a => FromJSON (ClientItem a)+instance HasCodec a => HasCodec (ClientItem a) where+  codec =+    object "ClientItem" $+      dimapCodec f g $+        disjointEitherCodec+          ( disjointEitherCodec+              (typeField "empty" <*> pure ())+              (typeField "added" <*> requiredField "value" "item that was added, client-side")+          )+          ( disjointEitherCodec+              (typeField "synced" <*> requiredField "value" "the item that is known, client-side")+              (typeField "deleted" <*> pure ())+          )+    where+      f :: Either (Either () a) (Either a ()) -> ClientItem a+      f = \case+        Left (Left ()) -> ClientEmpty+        Left (Right v) -> ClientAdded v+        Right (Left v) -> ClientSynced v+        Right (Right ()) -> ClientDeleted+      g :: ClientItem a -> Either (Either () a) (Either a ())+      g = \case+        ClientEmpty -> Left (Left ())+        ClientAdded v -> Left (Right v)+        ClientSynced v -> Right (Left v)+        ClientDeleted -> Right (Right ()) -instance ToJSON a => ToJSON (ClientItem a)+      typeField :: Text -> ObjectCodec b (x -> x)+      typeField typeName = id <$ requiredFieldWith' "type" (literalTextCodec typeName) .= const typeName  -- | A synchronisation request for items with identifiers of type @i@ and values of type @a@ data ItemSyncRequest a   = ItemSyncRequestPoll-  | ItemSyncRequestNew a+  | ItemSyncRequestNew !a   | ItemSyncRequestKnown   | ItemSyncRequestDeleted-  deriving (Show, Eq, Ord, Generic)+  deriving stock (Show, Eq, Ord, Generic)+  deriving (FromJSON, ToJSON) via (Autodocodec (ItemSyncRequest a))  instance Validity a => Validity (ItemSyncRequest a)  instance NFData a => NFData (ItemSyncRequest a) -instance FromJSON a => FromJSON (ItemSyncRequest a)+instance HasCodec a => HasCodec (ItemSyncRequest a) where+  codec =+    object "ItemSyncRequest" $+      dimapCodec f g $+        disjointEitherCodec+          ( disjointEitherCodec+              (typeField "empty" <*> pure ())+              (typeField "added" <*> requiredField "value" "item that was added, client-side")+          )+          ( disjointEitherCodec+              (typeField "synced" <*> pure ())+              (typeField "deleted" <*> pure ())+          )+    where+      f = \case+        Left (Left ()) -> ItemSyncRequestPoll+        Left (Right v) -> ItemSyncRequestNew v+        Right (Left ()) -> ItemSyncRequestKnown+        Right (Right ()) -> ItemSyncRequestDeleted -instance ToJSON a => ToJSON (ItemSyncRequest a)+      g = \case+        ItemSyncRequestPoll -> Left (Left ())+        ItemSyncRequestNew v -> Left (Right v)+        ItemSyncRequestKnown -> Right (Left ())+        ItemSyncRequestDeleted -> Right (Right ()) +      typeField :: Text -> ObjectCodec b (x -> x)+      typeField typeName = id <$ requiredFieldWith' "type" (literalTextCodec typeName) .= const typeName+ makeItemSyncRequest :: ClientItem a -> ItemSyncRequest a makeItemSyncRequest ci =   case ci of@@ -60,16 +117,52 @@   | ItemSyncResponseClientDeleted   | ItemSyncResponseServerAdded !a   | ItemSyncResponseServerDeleted-  deriving (Show, Eq, Ord, Generic)+  deriving stock (Show, Eq, Ord, Generic)+  deriving (FromJSON, ToJSON) via (Autodocodec (ItemSyncResponse a))  instance Validity a => Validity (ItemSyncResponse a)  instance NFData a => NFData (ItemSyncResponse a) -instance FromJSON a => FromJSON (ItemSyncResponse a)+instance HasCodec a => HasCodec (ItemSyncResponse a) where+  codec =+    object "ItemSyncResponse" $+      dimapCodec f g $+        disjointEitherCodec+          ( disjointEitherCodec+              (typeField "in-sync-empty" <*> pure ())+              (typeField "in-sync-full" <*> pure ())+          )+          ( disjointEitherCodec+              ( disjointEitherCodec+                  (typeField "client-added" <*> pure ())+                  (typeField "client-deleted" <*> pure ())+              )+              ( disjointEitherCodec+                  (typeField "server-added" <*> requiredField "value" "the value that was added, server-side")+                  (typeField "server-deleted" <*> pure ())+              )+          )+    where+      f = \case+        Left (Left ()) -> ItemSyncResponseInSyncEmpty+        Left (Right ()) -> ItemSyncResponseInSyncFull+        Right (Left (Left ())) -> ItemSyncResponseClientAdded+        Right (Left (Right ())) -> ItemSyncResponseClientDeleted+        Right (Right (Left v)) -> ItemSyncResponseServerAdded v+        Right (Right (Right ())) -> ItemSyncResponseServerDeleted -instance ToJSON a => ToJSON (ItemSyncResponse a)+      g = \case+        ItemSyncResponseInSyncEmpty -> Left (Left ())+        ItemSyncResponseInSyncFull -> Left (Right ())+        ItemSyncResponseClientAdded -> Right (Left (Left ()))+        ItemSyncResponseClientDeleted -> Right (Left (Right ()))+        ItemSyncResponseServerAdded v -> Right (Right (Left v))+        ItemSyncResponseServerDeleted -> Right (Right (Right ())) +      typeField :: Text -> ObjectCodec b (x -> x)+      typeField typeName = id <$ requiredFieldWith' "type" (literalTextCodec typeName) .= const typeName+ -- | Merge a synchronisation response back into a client-side store. mergeItemSyncResponse :: ClientItem a -> ItemSyncResponse a -> ClientItem a mergeItemSyncResponse ci sr =@@ -102,15 +195,27 @@ data ServerItem a   = ServerItemEmpty   | ServerItemFull !a-  deriving (Show, Eq, Ord, Generic)+  deriving stock (Show, Eq, Ord, Generic)+  deriving (FromJSON, ToJSON) via (Autodocodec (ServerItem a))  instance Validity a => Validity (ServerItem a)  instance NFData a => NFData (ServerItem a) -instance FromJSON a => FromJSON (ServerItem a)--instance ToJSON a => ToJSON (ServerItem a)+instance HasCodec a => HasCodec (ServerItem a) where+  codec =+    object "ServerItem" $+      dimapCodec f g $+        possiblyJointEitherCodec+          (requiredField "value" "the item on the server side")+          (pure ())+    where+      f = \case+        Left v -> ServerItemFull v+        Right () -> ServerItemEmpty+      g = \case+        ServerItemFull v -> Left v+        ServerItemEmpty -> Right ()  processServerItemSync :: ServerItem a -> ItemSyncRequest a -> (ItemSyncResponse a, ServerItem a) processServerItemSync si sr =