diff --git a/src/Database/LSMTree.hs b/src/Database/LSMTree.hs index 6282a30bd..6d5fa3aa9 100644 --- a/src/Database/LSMTree.hs +++ b/src/Database/LSMTree.hs @@ -92,6 +92,8 @@ module Database.LSMTree ( -- ** Properties , resolveValueValidOutput , resolveValueAssociativity + -- ** DerivingVia wrappers + , ResolveAsFirst (..) -- * Utility types , IOLike @@ -113,6 +115,7 @@ import qualified Database.LSMTree.Common as Common import qualified Database.LSMTree.Internal as Internal import qualified Database.LSMTree.Internal.BlobRef as Internal import qualified Database.LSMTree.Internal.Entry as Entry +import qualified Database.LSMTree.Internal.RawBytes as RB import qualified Database.LSMTree.Internal.Serialise as Internal import qualified Database.LSMTree.Internal.Snapshot as Internal import qualified Database.LSMTree.Internal.Vector as V @@ -536,3 +539,20 @@ union = error "union: not yet implemented" $ union @m @k @v @b resolve :: forall v. ResolveValue v => Proxy v -> Internal.ResolveSerialisedValue resolve = coerce . resolveValue + +-- | Newtype wrapper for use with deriving via, which resolves values as a +-- 'Data.Semigroup.First' semigroup. +-- +-- The instance makes 'Insert's isomorphic to 'Mupsert's. This can be a sensible +-- default if there is no intent to use 'Mupsert's. +newtype ResolveAsFirst v = ResolveAsFirst v + deriving stock (Show, Eq, Ord) + deriving newtype SerialiseValue + +instance ResolveValue (ResolveAsFirst v) where + resolveValue :: + Proxy (ResolveAsFirst v) + -> RB.RawBytes + -> RB.RawBytes + -> RB.RawBytes + resolveValue _ x _ = x