diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,28 @@ +# Changelog + +## 0.1.0.0 - 2026-07-12 + +- Initial release of the boundary-aware delta calculus layered over + `moonlight-core`. +- Checked patch surface (`Moonlight.Delta.Patch`). A `CellPatch` records both + endpoints of a change — `AssertAbsent`, `Insert`, `Delete before`, `Replace + before after` — so applying one is a verified transition rather than an + overwrite. `apply`, `compose`, and `replay` are all checked; `diff` and + `invert` are total. Stale writes, missing-row races, duplicate inserts, and + invalid deletes come back as typed `ApplyError`/`ComposeError`/`ReplayError` + instead of silent last-write-wins. +- Signed deltas (`Moonlight.Delta.Signed`) with normalize, identity, + associativity, and inverse laws. +- Frontier, support, and monotone modules (`Moonlight.Delta.Frontier`, + `.Support`, `.Monotone`). Monotone composition holds under an associative + join; `ResetDelta` is a deliberate left-absorbing rebase, documented as such. +- Epoch calculus (`Moonlight.Delta.Epoch`): unbounded `Version` values, + versioned `Endpoint` objects, checked `EpochDelta` construction, + `transportKeys`, `transportView`, and checked composition. +- The layer also ships repair, scope, normalization, operator, and time modules + (`Moonlight.Delta.Repair`, `.Scope`, `.Normalize`, `.Operator`, `.Time`). +- Law families are named through `Moonlight.Core.LawName` ADTs and checked via a + proof-manifest helper; a reference model backs the patch and epoch suites. +- Public package surfaces are `Moonlight.Delta.Patch`, + `Moonlight.Delta.Epoch`, `Moonlight.Delta.Repair`, and the modules in the + `moonlight-delta-core` sublibrary. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 The Blue Rose, Rosalia Fialkova + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,229 @@ +# moonlight-delta + +> Part of **Moonlight**, the sheaf-theoretic computation layer beneath +> [Melusine](https://bluerose.blue) and Pale Meridian. + +`moonlight-delta` is Moonlight's checked state-change algebra: keyed patches, signed +multiplicities, invalidation scopes, frontiers, epochs, monotone operators, and bounded +repair. Operations return typed incompatibilities where a transition cannot be applied. + +## Main idea + +A `CellPatch value` records both endpoints of one keyed transition: absent to absent, +absent to present, present to absent, or present to present. Build cells with +`assertAbsent`, `insert`, `delete`, `replace`, or `cellFromEndpoints`. `apply` checks +the before endpoint, and `compose` checks that adjacent endpoints connect. + +Use patches for concurrent updates, retries, synchronization, authorization-sensitive +changes, and reconciliation. + +## Use + +```haskell +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Moonlight.Delta.Patch qualified as Patch + +changeTitle :: Patch.Patch Int String +changeTitle = Patch.singleton 7 (Patch.replace "Draft" "Published") + +committed + :: Either (Patch.ApplyError Int String) (Map Int String) +committed = Patch.apply changeTitle (Map.singleton 7 "Draft") +``` + +## Cookbook + +### Compose and replay patches + +`compose newer older` collapses two connected transitions. `replay` applies a +chronological sequence and reports the failing index. + +```haskell +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Moonlight.Delta.Patch qualified as Patch + +draft, reviewed, published :: Map Int String +draft = Map.singleton 7 "Draft" +reviewed = Map.singleton 7 "Review" +published = Map.singleton 7 "Published" + +draftToReview, reviewToPublished :: Patch.Patch Int String +draftToReview = Patch.diff draft reviewed +reviewToPublished = Patch.diff reviewed published + +publication + :: Either (Patch.ComposeError Int String) (Patch.Patch Int String) +publication = Patch.compose reviewToPublished draftToReview + +replayed + :: Either (Patch.ReplayError Int String) (Map Int String) +replayed = Patch.replay [draftToReview, reviewToPublished] draft + +history + :: Either (Patch.ComposeError Int String) (Patch.Patch Int String) +history = + Patch.recordMany + [ (7, Patch.replace "Draft" "Review") + , (7, Patch.replace "Review" "Published") + ] +``` + +Use `invert` to reverse a patch. Repeated temporal keys belong in `recordMany`; +`fromList` instead means authoritative, last-wins rows. + +### Apply signed multiplicities + +`Signed` stores integer changes while the state retains non-negative multiplicities. + +```haskell +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Moonlight.Delta.Signed qualified as Signed + +inventory :: Map String Signed.Multiplicity +inventory = Map.singleton "rose" (Signed.Multiplicity 2) + +sale :: Signed.Signed String +sale = Signed.signedFromList [("rose", -1), ("lily", 2)] + +afterSale + :: Either + (Signed.SignedApplyError String) + (Map String Signed.Multiplicity) +afterSale = Signed.applySignedToMap sale inventory +``` + +An underflow returns `SignedMultiplicityUnderflow`; a zero result removes the row. +Combine changes with `combineSigned` and reverse one with `negateSigned`. + +### Bound invalidation with a scope + +`Scope` distinguishes no invalidation, a finite dirty set, and global invalidation. + +```haskell +import Data.Set (Set) +import Data.Set qualified as Set +import Moonlight.Delta.Scope qualified as Scope + +dirtyPages :: Scope.Scope (Set Int) +dirtyPages = Scope.dirtyScope (Set.fromList [2, 7]) + +visibleDirtyPages :: Scope.Scope (Set Int) +visibleDirtyPages = Scope.restrictScope (Set.singleton 7) dirtyPages +``` + +`scopeKeys` returns `Nothing` for `fullScope`. + +### Track two-axis progress + +`ProductFrontier2` canonicalizes a two-dimensional progress skyline by removing +dominated points. + +```haskell +import Moonlight.Delta.Frontier qualified as Frontier + +progress :: Frontier.ProductFrontier2 Int Int +progress = Frontier.mkProductFrontier2 [(0, 3), (1, 2), (2, 1), (3, 0)] + +covered :: Bool +covered = Frontier.productFrontier2Contains (2, 2) progress +``` + +Use `mkFrontier` or `mkUpperFrontier` for a general `PartialOrder`. + +### Transport keys across an epoch + +An `EpochDelta` checks a partial transport between versioned key universes. A query is +partitioned into transported, retired, and unknown keys. + +```haskell +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet +import Moonlight.Delta.Epoch qualified as Epoch + +source, target :: Epoch.Endpoint IntSet +source = Epoch.Endpoint Epoch.initialVersion (IntSet.fromList [10, 20]) +target = + Epoch.Endpoint + (Epoch.nextVersion Epoch.initialVersion) + (IntSet.fromList [11, 30]) + +advance + :: Either + (Epoch.DeltaViolation Int) + (Epoch.EpochDelta (IntMap Int) IntSet) +advance = + Epoch.epochDelta + source + target + (IntMap.singleton 10 11) + (IntSet.singleton 20) + (IntSet.singleton 10) + +query + :: Either (Epoch.DeltaViolation Int) (Epoch.Transport (IntMap Int) IntSet) +query = + fmap + (\deltaValue -> Epoch.transportKeys deltaValue (IntSet.fromList [10, 20, 99])) + advance +``` + +Invalid versions, universes, transports, retirements, or changed keys return a +`DeltaViolation`. Here `query` partitions `10 -> 11`, retired `20`, and unknown `99`; +changed key `10` and fresh key `30` determine the dirty target set. + +### Run bounded repair + +A repair `Kernel` checks obstructions, turns repairable ones into corrections, and +applies those corrections under explicit fuel. + +```haskell +import Data.List.NonEmpty (NonEmpty ((:|))) +import Moonlight.Delta.Repair qualified as Repair + +data TooSmall = TooSmall Int +data Increment = Increment + +incrementKernel :: Int -> Repair.Kernel Int TooSmall Increment +incrementKernel target = + Repair.Kernel + { Repair.check = \state -> + if state >= target + then Repair.StepConverged state + else Repair.StepObstructed state (TooSmall target :| []) + , Repair.residuate = \_ -> Just Increment + , Repair.applyKernelCorrection = \state Increment -> state + 1 + } + +repaired :: Repair.Result Int TooSmall +repaired = Repair.boundedRepair (incrementKernel 2) (Repair.Config 4) 0 +``` + +The result is `ResultConverged 2 2`; the other terminal cases are `ResultStuck` and +`ResultBudgetExhausted`. Compose kernels with `sequenceRepair`, `productRepair`, or +`focusRepair`. + +## Surface & boundaries + +There is no umbrella library. Depend on the smallest public slice you use. + +| Cabal dependency | Import | What you get | +| --- | --- | --- | +| `moonlight-delta:moonlight-delta-core` | `Moonlight.Delta.Signed`, `.Scope`, `.Frontier`, `.Monotone`, `.Normalize`, `.Support`, `.Operator`, `.Time` | Signed changes, invalidation, progress frontiers, operators, and their shared laws. | +| `moonlight-delta:moonlight-delta-patch` | `Moonlight.Delta.Patch` | Checked keyed transitions, composition, diff, inversion, and replay. | +| `moonlight-delta:moonlight-delta-epoch` | `Moonlight.Delta.Epoch` | Versioned partial key transport and view restamping. | +| `moonlight-delta:moonlight-delta-repair` | `Moonlight.Delta.Repair` | Bounded obstruction repair and kernel composition. | + +## Test + +```bash +cabal test moonlight-delta:moonlight-delta-test +``` + +## License + +MIT. See `LICENSE`. diff --git a/bench/aggregate/Main.hs b/bench/aggregate/Main.hs new file mode 100644 --- /dev/null +++ b/bench/aggregate/Main.hs @@ -0,0 +1,33 @@ +module Main + ( main, + ) +where + +import BenchSupport + ( readStateScale, + ) +import CoreBench + ( coreBenchmarks, + ) +import EpochBench + ( epochBenchmarks, + ) +import PatchBench + ( patchBenchmarks, + ) +import Patch.Allocation + ( runPatchAllocationOrBenchmarks, + ) +import RepairBench + ( repairBenchmarks, + ) + +main :: IO () +main = do + stateScale <- readStateScale + runPatchAllocationOrBenchmarks + [ coreBenchmarks, + patchBenchmarks stateScale, + epochBenchmarks, + repairBenchmarks + ] diff --git a/bench/core/CoreBench.hs b/bench/core/CoreBench.hs new file mode 100644 --- /dev/null +++ b/bench/core/CoreBench.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE BangPatterns #-} + +module CoreBench + ( coreBenchmarks, + ) +where + +import Data.IntSet + ( IntSet, + ) +import Data.IntSet qualified as IntSet +import Data.Map.Strict + ( Map, + ) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import BenchSupport + ( benchFailure, + caseLabel, + deltaSizes, + frontierDominatedSizes, + frontierSizes, + keys, + naturalWeight, + repeatedDeltaKeys, + ) +import Moonlight.Delta.Frontier + ( frontierContains, + frontierPoints, + mkFrontier, + mkProductFrontier2, + productFrontier2Contains, + productFrontier2Points, + ) +import Moonlight.Delta.Normalize + ( normalizeDelta, + ) +import Moonlight.Delta.Scope + ( Scope, + dirtyScope, + restrictScope, + scopeKeys, + unionScope, + ) +import Moonlight.Delta.Signed + ( Multiplicity (..), + SignedApplyError, + Signed, + applySignedToMap, + combineSigned, + signedFromList, + signedNull, + support, + ) +import Test.Tasty.Bench + ( Benchmark, + bench, + bgroup, + nf, + whnf, + ) + +coreBenchmarks :: Benchmark +coreBenchmarks = + bgroup + "core" + [ signedDeltaBenchmarks, + frontierBenchmarks, + scopeBenchmarks + ] + +signedDeltaBenchmarks :: Benchmark +signedDeltaBenchmarks = + bgroup + "signed-delta" + (deltaSizes >>= signedDeltaBenchmarksForSize) + +signedDeltaBenchmarksForSize :: Int -> [Benchmark] +signedDeltaBenchmarksForSize size = + [ bench (caseLabel "prepared normalize" size) (whnf normalizeDelta preparedDelta), + bench (caseLabel "prepared null" size) (whnf signedNull preparedDelta), + bench (caseLabel "prepared support" size) (nf (Set.size . support) preparedDelta), + bench (caseLabel "fromList/normalize" size) (nf signedBuildWeight size), + bench (caseLabel "build/combine" size) (nf signedComposeSizeWeight size), + bench (caseLabel "build/apply to map" size) (nf signedApplySizeWeight size), + bench (caseLabel "apply first underflow" size) (nf signedFirstUnderflowWeight (signedFirstUnderflowDelta size)), + bench (caseLabel "repeated sparse apply stream" size) (nf signedRepeatedSparseApplyWeight size) + ] + where + preparedDelta = + signedDelta size + +signedFirstUnderflowDelta :: Int -> Signed Int +signedFirstUnderflowDelta size = + signedFromList ((0, -1) : fmap (\key -> (key, 1)) [1 .. max 0 (size - 1)]) + +signedFirstUnderflowWeight :: Signed Int -> Int +signedFirstUnderflowWeight deltaValue = + case applySignedToMap deltaValue Map.empty of + Left _underflow -> 1 + Right unexpectedState -> Map.size unexpectedState + +signedBuildWeight :: Int -> Int +signedBuildWeight = + Set.size . support . signedDelta + +signedComposeWeight :: (Signed Int, Signed Int) -> Int +signedComposeWeight (newer, older) = + Set.size (support (combineSigned newer older)) + +signedComposeSizeWeight :: Int -> Int +signedComposeSizeWeight size = + signedComposeWeight (signedDelta size, shiftedSigned size) + +signedApplySizeWeight :: Int -> Int +signedApplySizeWeight size = + signedApplyWeight (initialSignedState size, signedDelta size) + +signedApplyWeight :: (Map Int Multiplicity, Signed Int) -> Int +signedApplyWeight (stateValue, deltaValue) = + case applySignedToMap deltaValue stateValue of + Left err -> benchFailure "signed apply" err + Right updatedState -> Map.size updatedState + +signedRepeatedSparseApplyWeight :: Int -> Int +signedRepeatedSparseApplyWeight size = + signedRepeatedApplyWeight (repeatedSignedInitialState, repeatedSignedStream size) + +signedRepeatedApplyWeight :: (Map Int Multiplicity, [Signed Int]) -> Int +signedRepeatedApplyWeight (initialState, deltas) = + case foldl' applySignedStreamStep (Right initialState) deltas of + Left err -> benchFailure "signed repeated apply" err + Right finalState -> Map.foldl' (\total (Multiplicity value) -> total + naturalWeight value) 0 finalState + +applySignedStreamStep :: Either (SignedApplyError Int) (Map Int Multiplicity) -> Signed Int -> Either (SignedApplyError Int) (Map Int Multiplicity) +applySignedStreamStep state deltaValue = + state >>= applySignedToMap deltaValue + +repeatedSignedInitialState :: Map Int Multiplicity +repeatedSignedInitialState = + Map.fromAscList (fmap (\key -> (key, Multiplicity 1)) repeatedDeltaKeys) + +repeatedSignedStream :: Int -> [Signed Int] +repeatedSignedStream size = + fmap + (\step -> + signedFromList + ( fmap + (\key -> (key, if even (key + step) then 1 else -1)) + repeatedDeltaKeys + ) + ) + (keys size) + +signedDelta :: Int -> Signed Int +signedDelta = + signedFromList . signedEntries + +shiftedSigned :: Int -> Signed Int +shiftedSigned size = + signedFromList + [ (key + 1, signedAmount key) + | key <- keys size + ] + +signedEntries :: Int -> [(Int, Int)] +signedEntries size = + [ (key, signedAmount key) + | key <- keys size + ] + +signedAmount :: Int -> Int +signedAmount key + | even key = 1 + | otherwise = -1 + +initialSignedState :: Int -> Map Int Multiplicity +initialSignedState size = + Map.fromAscList + [ (key, Multiplicity 1) + | key <- keys (size + 1) + ] + +frontierBenchmarks :: Benchmark +frontierBenchmarks = + bgroup + "frontier-antichain" + ( (frontierSizes >>= frontierDiagonalBenchmarksForSize) + <> (frontierDominatedSizes >>= frontierDominatedBenchmarksForSize) + ) + +frontierDiagonalBenchmarksForSize :: Int -> [Benchmark] +frontierDiagonalBenchmarksForSize size = + [ bench (caseLabel "generic build diagonal" size) (nf genericFrontierBuildWeight size), + bench (caseLabel "product2 build diagonal" size) (nf productFrontierBuildWeight size), + bench (caseLabel "generic build/contains sweep" size) (nf genericFrontierContainsSizeWeight size), + bench (caseLabel "product2 build/contains sweep" size) (nf productFrontierContainsSizeWeight size) + ] + +frontierDominatedBenchmarksForSize :: Int -> [Benchmark] +frontierDominatedBenchmarksForSize size = + [ bench (caseLabel "generic dominated-chain build/contains" size) (nf genericFrontierDominatedContainsWeight size), + bench (caseLabel "product2 dominated-chain build/contains" size) (nf productFrontierDominatedContainsWeight size) + ] + +genericFrontierBuildWeight :: Int -> Int +genericFrontierBuildWeight = + length . frontierPoints . mkFrontier . frontierDiagonal + +productFrontierBuildWeight :: Int -> Int +productFrontierBuildWeight = + length . productFrontier2Points . mkProductFrontier2 . frontierDiagonal + +genericFrontierContainsSizeWeight :: Int -> Int +genericFrontierContainsSizeWeight size = + let frontier = + mkFrontier (frontierDiagonal size) + in length + ( filter + (\point -> frontierContains point frontier) + (frontierProbePoints size) + ) + +productFrontierContainsSizeWeight :: Int -> Int +productFrontierContainsSizeWeight size = + let frontier = + mkProductFrontier2 (frontierDiagonal size) + in length + ( filter + (\point -> productFrontier2Contains point frontier) + (frontierProbePoints size) + ) + +genericFrontierDominatedContainsWeight :: Int -> Int +genericFrontierDominatedContainsWeight size = + let frontier = + mkFrontier (frontierDominatedChain size) + in length + ( filter + (\point -> frontierContains point frontier) + (frontierProbePoints size) + ) + +productFrontierDominatedContainsWeight :: Int -> Int +productFrontierDominatedContainsWeight size = + let frontier = + mkProductFrontier2 (frontierDominatedChain size) + in length + ( filter + (\point -> productFrontier2Contains point frontier) + (frontierProbePoints size) + ) + +frontierDiagonal :: Int -> [(Int, Int)] +frontierDiagonal size = + [ (key, size - key) + | key <- keys size + ] + +frontierProbePoints :: Int -> [(Int, Int)] +frontierProbePoints size = + fmap (\key -> (key, key)) (keys size) + +frontierDominatedChain :: Int -> [(Int, Int)] +frontierDominatedChain size = + fmap (\key -> (key, key)) (keys size) + +scopeBenchmarks :: Benchmark +scopeBenchmarks = + bgroup + "scope" + (deltaSizes >>= scopeBenchmarksForSize) + +scopeBenchmarksForSize :: Int -> [Benchmark] +scopeBenchmarksForSize size = + [ bench (caseLabel "Scope union/restrict" size) (nf scopeUnionRestrictWeight size) + ] + +scopeUnionRestrictWeight :: Int -> Int +scopeUnionRestrictWeight size = + scopeWeight + ( restrictScope + (IntSet.fromAscList (sampleKeys size)) + (unionScope (dirtyScope (evenKeySet size)) (dirtyScope (thirdKeySet size))) + ) + +scopeWeight :: Scope IntSet -> Int +scopeWeight = + maybe 0 IntSet.size . scopeKeys + +evenKeySet :: Int -> IntSet +evenKeySet size = + IntSet.fromAscList + [ key + | key <- keys size, + even key + ] + +thirdKeySet :: Int -> IntSet +thirdKeySet size = + IntSet.fromAscList + [ key + | key <- keys size, + key `mod` 3 == 0 + ] + +sampleKeys :: Int -> [Int] +sampleKeys size = + keys size diff --git a/bench/core/Main.hs b/bench/core/Main.hs new file mode 100644 --- /dev/null +++ b/bench/core/Main.hs @@ -0,0 +1,13 @@ +module Main + ( main, + ) +where + +import CoreBench + ( coreBenchmarks, + ) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [coreBenchmarks] diff --git a/bench/epoch/EpochBench.hs b/bench/epoch/EpochBench.hs new file mode 100644 --- /dev/null +++ b/bench/epoch/EpochBench.hs @@ -0,0 +1,150 @@ +module EpochBench + ( epochBenchmarks, + ) +where + +import Data.IntMap.Strict + ( IntMap, + ) +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet + ( IntSet, + ) +import Data.IntSet qualified as IntSet +import BenchSupport + ( benchFailure, + caseLabel, + deltaSizes, + keys, + repeatedDeltaKeys, + ) +import Moonlight.Delta.Epoch + ( ContextProjectionDelta (..), + EpochDelta, + Endpoint (..), + changedKeysAcrossEpoch, + dirtyBaseDelta, + dirtyResultDelta, + epochDelta, + versionFromKey, + ) +import Test.Tasty.Bench + ( Benchmark, + bench, + bgroup, + nf, + ) + +epochBenchmarks :: Benchmark +epochBenchmarks = + bgroup + "epoch" + (deltaSizes >>= epochBenchmarksForSize) + +epochBenchmarksForSize :: Int -> [Benchmark] +epochBenchmarksForSize size = + [ bench (caseLabel "ContextProjectionDelta union" size) (nf contextProjectionUnionWeight size), + bench (caseLabel "EpochDelta changedKeys" size) (nf epochChangedKeysWeight size), + bench (caseLabel "EpochDelta changedKeys production identity transport large universe" size) (nf epochProductionChangedKeysWeight size), + bench (caseLabel "EpochDelta changedKeys sparse transport large universe" size) (nf epochSparseChangedKeysWeight size) + ] + +contextProjectionUnionWeight :: Int -> Int +contextProjectionUnionWeight size = + contextProjectionWeight + ( foldMap + (\key -> dirtyBaseDelta key <> dirtyResultDelta (key + 1)) + (sampleKeys size) + ) + +epochChangedKeysWeight :: Int -> Int +epochChangedKeysWeight size = + IntSet.size (changedKeysAcrossEpoch (epochDeltaForSize size)) + +epochProductionChangedKeysWeight :: Int -> Int +epochProductionChangedKeysWeight size = + IntSet.size (changedKeysAcrossEpoch (epochProductionDeltaForSize size)) + +epochSparseChangedKeysWeight :: Int -> Int +epochSparseChangedKeysWeight size = + IntSet.size (changedKeysAcrossEpoch (epochSparseDeltaForSize size)) + +epochDeltaForSize :: Int -> EpochDelta (IntMap Int) IntSet +epochDeltaForSize size = + mintEpochBenchmarkDelta + "epoch changedKeys" + (IntSet.fromAscList (sampleKeys size)) + ( IntSet.fromAscList + (fmap (+ size) (sampleKeys size) <> fmap (+ (2 * size)) (sampleKeys size)) + ) + (IntMap.fromAscList [(key, key + size) | key <- sampleKeys size]) + IntSet.empty + (IntSet.fromAscList (sampleKeys size)) + +epochProductionDeltaForSize :: Int -> EpochDelta (IntMap Int) IntSet +epochProductionDeltaForSize size = + mintEpochBenchmarkDelta + "epoch changedKeys production" + largeUniverse + largeUniverse + IntMap.empty + IntSet.empty + (IntSet.fromAscList (sampleKeys size)) + where + largeUniverse = + epochLargeUniverse size + +epochSparseDeltaForSize :: Int -> EpochDelta (IntMap Int) IntSet +epochSparseDeltaForSize size = + mintEpochBenchmarkDelta + "epoch changedKeys sparse" + sourceUniverse + targetUniverse + transport + IntSet.empty + (IntSet.fromAscList sparseDomain) + where + sourceUniverse = + epochLargeUniverse size + sparseDomain = + repeatedDeltaKeys + largeSize = + size * 64 + transport = + IntMap.fromAscList [(key, largeSize + key) | key <- sparseDomain] + targetUniverse = + IntSet.union + (IntSet.difference sourceUniverse (IntSet.fromAscList sparseDomain)) + (IntSet.fromAscList [largeSize + key | key <- sparseDomain]) + +mintEpochBenchmarkDelta :: + String -> + IntSet -> + IntSet -> + IntMap Int -> + IntSet -> + IntSet -> + EpochDelta (IntMap Int) IntSet +mintEpochBenchmarkDelta label sourceKeys targetKeys transport retiredKeys changedKeys = + case epochDelta source target transport retiredKeys changedKeys of + Left err -> + benchFailure label err + Right deltaValue -> + deltaValue + where + source = + Endpoint (versionFromKey 1) sourceKeys + target = + Endpoint (versionFromKey 2) targetKeys + +epochLargeUniverse :: Int -> IntSet +epochLargeUniverse size = + IntSet.fromAscList (keys (size * 64)) + +contextProjectionWeight :: ContextProjectionDelta IntSet -> Int +contextProjectionWeight deltaValue = + IntSet.size (dirtyBaseKeys deltaValue) + IntSet.size (dirtyResultKeys deltaValue) + +sampleKeys :: Int -> [Int] +sampleKeys size = + keys size diff --git a/bench/epoch/Main.hs b/bench/epoch/Main.hs new file mode 100644 --- /dev/null +++ b/bench/epoch/Main.hs @@ -0,0 +1,13 @@ +module Main + ( main, + ) +where + +import EpochBench + ( epochBenchmarks, + ) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [epochBenchmarks] diff --git a/bench/patch/Main.hs b/bench/patch/Main.hs new file mode 100644 --- /dev/null +++ b/bench/patch/Main.hs @@ -0,0 +1,17 @@ +module Main + ( main, + ) +where + +import BenchSupport (readStateScale) +import PatchBench + ( patchBenchmarks, + ) +import Patch.Allocation + ( runPatchAllocationOrBenchmarks, + ) + +main :: IO () +main = do + stateScale <- readStateScale + runPatchAllocationOrBenchmarks [patchBenchmarks stateScale] diff --git a/bench/patch/Patch/Allocation.hs b/bench/patch/Patch/Allocation.hs new file mode 100644 --- /dev/null +++ b/bench/patch/Patch/Allocation.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE BangPatterns #-} + +module Patch.Allocation + ( runPatchAllocationOrBenchmarks, + writePatchAllocationCsv, + ) +where + +import Control.Exception + ( evaluate, + ) +import Control.Monad + ( foldM, + ) +import Data.Word + ( Word64, + ) +import GHC.Stats + ( RTSStats (allocated_bytes), + getRTSStats, + getRTSStatsEnabled, + ) +import BenchSupport + ( caseLabel, + defaultAllocationRepetitions, + forceBenchmarkFixture, + halfSize, + lastKey, + mapIntWeight, + middleKey, + patchDeltaSizes, + quarterSize, + ) +import PatchBench + ( hackagePatchApplyConstructionAllocationWeight, + hackagePatchApplyForcedConstructionWeight, + hackagePatchComposeConstructionAllocationWeight, + hackagePatchComposeForcedConstructionWeight, + hackagePatchReplayForcedWeight, + hackagePatchReplayWeight, + patchApplyConstructionAllocationWeight, + patchApplyForcedConstructionWeight, + patchApplyOutcomeFixtureWeight, + patchApplyReferenceOutcomeFixtureWeight, + patchComposeConstructionAllocationWeight, + patchComposeForcedConstructionWeight, + patchFusedReplayForcedWeight, + patchFusedReplayOutcomeWeight, + patchFusedReplayWeight, + patchSequentialReferenceReplayForcedWeight, + patchSequentialReferenceReplayOutcomeWeight, + patchSequentialReferenceReplayWeight, + patchSequentialReplayForcedWeight, + patchSequentialReplayOutcomeWeight, + patchSequentialReplayWeight, + prepareHackagePatchApplyOutput, + prepareHackagePatchComposeOutput, + preparePatchApplyOutput, + preparePatchComposeOutput, + ) +import Patch.Fixtures +import Patch.Hackage + ( hackagePatchMapWeight, + prepareHackagePatchApplyFixture, + prepareHackagePatchComposeFixture, + prepareHackagePatchReplayFixture, + ) +import Patch.Types +import Moonlight.Delta.Patch qualified as Patch +import PatchReference qualified +import System.Environment + ( getArgs, + ) +import System.Exit + ( die, + ) +import System.Mem + ( performGC, + ) +import Test.Tasty.Bench + ( Benchmark, + defaultMain, + ) +import Text.Read + ( readMaybe, + ) + +runPatchAllocationOrBenchmarks :: [Benchmark] -> IO () +runPatchAllocationOrBenchmarks benchmarks = do + args <- getArgs + case parseAllocationRequest args of + Left message -> + die message + Right Nothing -> + defaultMain benchmarks + Right (Just (path, repetitions)) -> + writePatchAllocationCsv path repetitions + +parseAllocationRequest :: [String] -> Either String (Maybe (FilePath, Int)) +parseAllocationRequest args = + case args of + ["--patch-allocation-csv", path] -> + Right (Just (path, defaultAllocationRepetitions)) + ["--patch-allocation-csv", path, "--allocation-repetitions", repetitionsText] -> + fmap (\repetitions -> Just (path, repetitions)) (parsePositiveRepetitions repetitionsText) + [] -> + Right Nothing + _ -> + if "--patch-allocation-csv" `elem` args || "--allocation-repetitions" `elem` args + then + Left + "usage: moonlight-delta-bench --patch-allocation-csv PATH [--allocation-repetitions POSITIVE_INT] +RTS -T" + else Right Nothing + +parsePositiveRepetitions :: String -> Either String Int +parsePositiveRepetitions repetitionsText = + case readMaybe repetitionsText of + Just repetitions | repetitions > 0 -> + Right repetitions + _ -> + Left ("invalid --allocation-repetitions value: " <> repetitionsText) + +patchAllocationCases :: [AllocationCase] +patchAllocationCases = + patchDeltaSizes >>= patchAllocationCasesForSize + +patchAllocationCasesForSize :: Int -> [AllocationCase] +patchAllocationCasesForSize size = + patchComposeAllocationCasesForSize size + <> patchApplyAllocationCasesForSize size + <> patchReplayAllocationCasesForSize size + <> patchDerivedAllocationCasesForSize size + +patchComposeAllocationCasesForSize :: Int -> [AllocationCase] +patchComposeAllocationCasesForSize size = + composeAllocationCases "compose overlap none" size (overlapPatchComposeFixture size 0) + <> composeAllocationCases "compose overlap quarter" size (overlapPatchComposeFixture size (quarterSize size)) + <> composeAllocationCases "compose overlap half" size (overlapPatchComposeFixture size (halfSize size)) + <> composeAllocationCases "compose overlap full" size (PatchComposeFixture (newerPatch size) (olderPatch size)) + <> composeAllocationCases "compose asymmetric newer sparse" size (PatchComposeFixture (sparseNewerPatch size) (olderPatch size)) + <> composeAllocationCases "compose asymmetric older sparse" size (PatchComposeFixture (newerPatch size) (sparseOlderPatch size)) + +patchApplyAllocationCasesForSize :: Int -> [AllocationCase] +patchApplyAllocationCasesForSize size = + applyAllocationCases "aligned whole checked apply" size (PatchApplyFixture (initialPatchState size) (olderPatch size)) + <> applyAllocationCases "sparse checked apply to large map" size (PatchApplyFixture (largeInitialPatchState size) (sparsePatch size)) + <> applyAllocationCases "shape-changing assert-absent checked apply" size (PatchApplyFixture (shapeChangingInitialState size) (shapeChangingPatch size)) + <> applyOutcomeAllocationCases "apply failure first key" size (patchApplyFailureFixture size 0) + <> applyOutcomeAllocationCases "apply failure middle key" size (patchApplyFailureFixture size (middleKey size)) + <> applyOutcomeAllocationCases "apply failure last key" size (patchApplyFailureFixture size (lastKey size)) + +patchReplayAllocationCasesForSize :: Int -> [AllocationCase] +patchReplayAllocationCasesForSize size = + replayAllocationCases + "stable sparse replay over large map" + size + (PatchReplayFixture (repeatedPatchInitialState size) (repeatedPatchStream size)) + <> replayAllocationCases + "rotating sparse replay over large map" + size + (PatchReplayFixture (repeatedPatchInitialState size) (rotatingPatchStream size)) + <> replayAllocationCases + "expanding sparse replay over large map" + size + (PatchReplayFixture (repeatedPatchInitialState size) (expandingPatchStream size)) + <> replayAllocationCases + "disjoint sparse replay over large map" + size + (PatchReplayFixture (largeInitialPatchState size) (disjointPatchStream size)) + <> replayAllocationCases + "insertion-deletion replay over large map" + size + (PatchReplayFixture (largeInitialPatchState size) (insertionDeletionPatchStream size)) + <> replayAllocationCases + "cancellation replay over large map" + size + (PatchReplayFixture (repeatedPatchInitialState size) (cancellationPatchStream size)) + <> replayOutcomeAllocationCases + "stale-at-first replay over large map" + size + (PatchReplayFixture (repeatedPatchInitialState size) (stalePatchStreamAt size 0)) + <> replayOutcomeAllocationCases + "stale-at-middle replay over large map" + size + (PatchReplayFixture (repeatedPatchInitialState size) (stalePatchStreamAt size (middleKey size))) + <> replayOutcomeAllocationCases + "stale-at-last replay over large map" + size + (PatchReplayFixture (repeatedPatchInitialState size) (stalePatchStreamAt size (lastKey size))) + +patchDerivedAllocationCasesForSize :: Int -> [AllocationCase] +patchDerivedAllocationCasesForSize size = + [ fixtureAllocationCase + (allocationScalarName "snapshot diff" size) + (preparePatchDiffFixture (PatchDiffFixture (snapshotDiffBeforeState size) (snapshotDiffAfterState size))) + patchDiffWeight, + fixtureAllocationCase + (allocationScalarName "invert insertion deletion patch" size) + (preparePatchInvertFixture (PatchInvertFixture (shapeChangingPatch size))) + patchInvertWeight, + fixtureAllocationCase + (allocationScalarName "support materialization" size) + (forceBenchmarkFixture (PatchSupportFixture (olderPatch size))) + patchSupportWeight, + fixtureAllocationCase + (allocationScalarName "repeated-key temporal recording one-by-one" size) + (forceBenchmarkFixture (PatchProducerFixture (producerCells size))) + patchProducerWeight, + fixtureAllocationCase + (allocationScalarName "recordApplied single-cell producer" size) + (forceBenchmarkFixture (PatchProducerFixture (singleCellProducerCells size))) + patchProducerWeight, + fixtureAllocationCase + (allocationScalarName "repeated-key temporal recording batch" size) + (forceBenchmarkFixture (PatchProducerFixture (producerCells size))) + patchProducerBatchWeight + ] + +composeAllocationCases :: String -> Int -> PatchComposeFixture -> [AllocationCase] +composeAllocationCases label size fixture = + let prepareFixture = + preparePatchComposeFixture fixture + prepareHackageFixture = + prepareHackagePatchComposeFixture fixture + in [ fixtureAllocationCase + (allocationVariantPhaseName label size checkedMapMergeLabel "construct") + prepareFixture + (patchComposeConstructionAllocationWeight PatchReference.compose), + fixtureAllocationCase + (allocationVariantPhaseName label size checkedMapMergeLabel "construct forced") + prepareFixture + (patchComposeForcedConstructionWeight PatchReference.compose), + fixtureAllocationCase + (allocationVariantPhaseName label size checkedMapMergeLabel "consume") + (prepareFixture >>= preparePatchComposeOutput checkedMapMergeLabel PatchReference.compose) + (patchDeltaWeight . preparedPatch), + fixtureAllocationCase + (allocationVariantPhaseName label size moonlightPagedPatchLabel "construct") + prepareFixture + (patchComposeConstructionAllocationWeight Patch.compose), + fixtureAllocationCase + (allocationVariantPhaseName label size moonlightPagedPatchLabel "construct forced") + prepareFixture + (patchComposeForcedConstructionWeight Patch.compose), + fixtureAllocationCase + (allocationVariantPhaseName label size moonlightPagedPatchLabel "consume") + (prepareFixture >>= preparePatchComposeOutput moonlightPagedPatchLabel Patch.compose) + (patchDeltaWeight . preparedPatch), + fixtureAllocationCase + (allocationVariantPhaseName label size hackagePatchMapLabel "construct") + prepareHackageFixture + hackagePatchComposeConstructionAllocationWeight, + fixtureAllocationCase + (allocationVariantPhaseName label size hackagePatchMapLabel "construct forced") + prepareHackageFixture + hackagePatchComposeForcedConstructionWeight, + fixtureAllocationCase + (allocationVariantPhaseName label size hackagePatchMapLabel "consume") + (prepareHackageFixture >>= prepareHackagePatchComposeOutput hackagePatchMapLabel) + (hackagePatchMapWeight . preparedHackagePatchMap) + ] + +applyAllocationCases :: String -> Int -> PatchApplyFixture -> [AllocationCase] +applyAllocationCases label size fixture = + let prepareFixture = + preparePatchApplyFixture fixture + prepareHackageFixture = + prepareHackagePatchApplyFixture fixture + in [ fixtureAllocationCase + (allocationVariantPhaseName label size checkedMapMergeLabel "construct") + prepareFixture + (patchApplyConstructionAllocationWeight PatchReference.apply), + fixtureAllocationCase + (allocationVariantPhaseName label size checkedMapMergeLabel "construct forced") + prepareFixture + (patchApplyForcedConstructionWeight PatchReference.apply), + fixtureAllocationCase + (allocationVariantPhaseName label size checkedMapMergeLabel "consume") + (prepareFixture >>= preparePatchApplyOutput checkedMapMergeLabel PatchReference.apply) + mapIntWeight, + fixtureAllocationCase + (allocationVariantPhaseName label size moonlightPagedPatchLabel "construct") + prepareFixture + (patchApplyConstructionAllocationWeight Patch.apply), + fixtureAllocationCase + (allocationVariantPhaseName label size moonlightPagedPatchLabel "construct forced") + prepareFixture + (patchApplyForcedConstructionWeight Patch.apply), + fixtureAllocationCase + (allocationVariantPhaseName label size moonlightPagedPatchLabel "consume") + (prepareFixture >>= preparePatchApplyOutput moonlightPagedPatchLabel Patch.apply) + mapIntWeight, + fixtureAllocationCase + (allocationVariantPhaseName label size hackagePatchMapLabel "construct") + prepareHackageFixture + hackagePatchApplyConstructionAllocationWeight, + fixtureAllocationCase + (allocationVariantPhaseName label size hackagePatchMapLabel "construct forced") + prepareHackageFixture + hackagePatchApplyForcedConstructionWeight, + fixtureAllocationCase + (allocationVariantPhaseName label size hackagePatchMapLabel "consume") + (prepareHackageFixture >>= prepareHackagePatchApplyOutput hackagePatchMapLabel) + mapIntWeight + ] + +applyOutcomeAllocationCases :: String -> Int -> PatchApplyFixture -> [AllocationCase] +applyOutcomeAllocationCases label size fixture = + [ fixtureAllocationCase + (allocationVariantName label size checkedMapMergeLabel) + (preparePatchApplyFixture fixture) + patchApplyReferenceOutcomeFixtureWeight, + fixtureAllocationCase + (allocationVariantName label size moonlightSplitApplyLabel) + (preparePatchApplyFixture fixture) + patchApplyOutcomeFixtureWeight + ] + +replayAllocationCases :: String -> Int -> PatchReplayFixture -> [AllocationCase] +replayAllocationCases label size fixture = + [ fixtureAllocationCase + (allocationVariantName label size checkedSequentialMapMergeLabel) + (preparePatchReplayFixture fixture) + patchSequentialReferenceReplayWeight, + fixtureAllocationCase + (allocationVariantPhaseName label size checkedSequentialMapMergeLabel "construct forced") + (preparePatchReplayFixture fixture) + patchSequentialReferenceReplayForcedWeight, + fixtureAllocationCase + (allocationVariantName label size moonlightSequentialApplyLabel) + (preparePatchReplayFixture fixture) + patchSequentialReplayWeight, + fixtureAllocationCase + (allocationVariantPhaseName label size moonlightSequentialApplyLabel "construct forced") + (preparePatchReplayFixture fixture) + patchSequentialReplayForcedWeight, + fixtureAllocationCase + (allocationVariantName label size moonlightUncheckedSequentialPatchLabel) + (preparePatchReplayFixture fixture) + patchUncheckedSequentialReplayWeight, + fixtureAllocationCase + (allocationVariantName label size hackageSequentialPatchMapLabel) + (prepareHackagePatchReplayFixture fixture) + hackagePatchReplayWeight, + fixtureAllocationCase + (allocationVariantPhaseName label size hackageSequentialPatchMapLabel "construct forced") + (prepareHackagePatchReplayFixture fixture) + hackagePatchReplayForcedWeight, + fixtureAllocationCase + (allocationVariantName label size moonlightFusedReplayLabel) + (preparePatchReplayFixture fixture) + patchFusedReplayWeight, + fixtureAllocationCase + (allocationVariantPhaseName label size moonlightFusedReplayLabel "construct forced") + (preparePatchReplayFixture fixture) + patchFusedReplayForcedWeight + ] + +replayOutcomeAllocationCases :: String -> Int -> PatchReplayFixture -> [AllocationCase] +replayOutcomeAllocationCases label size fixture = + [ fixtureAllocationCase + (allocationVariantName label size checkedSequentialMapMergeLabel) + (preparePatchReplayFixture fixture) + patchSequentialReferenceReplayOutcomeWeight, + fixtureAllocationCase + (allocationVariantName label size moonlightSequentialApplyLabel) + (preparePatchReplayFixture fixture) + patchSequentialReplayOutcomeWeight, + fixtureAllocationCase + (allocationVariantName label size moonlightFusedReplayLabel) + (preparePatchReplayFixture fixture) + patchFusedReplayOutcomeWeight + ] + +fixtureAllocationCase :: + String -> + IO fixture -> + (fixture -> Int) -> + AllocationCase +fixtureAllocationCase name prepareFixture weighFixture = + AllocationCase + { allocationCaseName = name, + allocationCaseAction = do + !fixture <- prepareFixture + pure + (\iteration -> + evaluate (freshAllocationWeight iteration weighFixture fixture) + ) + } + +allocationVariantName :: String -> Int -> String -> String +allocationVariantName label size variant = + allocationScalarName label size <> "." <> variant + +allocationScalarName :: String -> Int -> String +allocationScalarName label size = + "All.patch." <> caseLabel label size + +allocationVariantPhaseName :: String -> Int -> String -> String -> String +allocationVariantPhaseName label size variant phase = + allocationVariantName label size (variant <> "." <> phase) + +writePatchAllocationCsv :: FilePath -> Int -> IO () +writePatchAllocationCsv path repetitions = do + ensureRtsStatsEnabled + results <- traverse (measureAllocationCase repetitions) patchAllocationCases + writeFile path (allocationCsv results) + +ensureRtsStatsEnabled :: IO () +ensureRtsStatsEnabled = do + enabled <- getRTSStatsEnabled + if enabled + then pure () + else die "RTS stats are disabled; rerun with +RTS -T" + +measureAllocationCase :: Int -> AllocationCase -> IO AllocationResult +measureAllocationCase repetitions allocationCase = do + action <- allocationCaseAction allocationCase + (baselineBytes, _baselineChecksum) <- + measureAllocatedBytes + repetitions + (\iteration -> evaluate (allocationBaseline iteration)) + (grossBytes, checksum) <- measureAllocatedBytes repetitions action + pure + AllocationResult + { allocationResultName = allocationCaseName allocationCase, + allocationResultGrossBytes = grossBytes, + allocationResultBaselineBytes = baselineBytes, + allocationResultNetBytes = fromIntegral grossBytes - fromIntegral baselineBytes, + allocationResultRepetitions = repetitions, + allocationResultChecksum = checksum + } + +measureAllocatedBytes :: Int -> (Int -> IO Int) -> IO (Word64, Int) +measureAllocatedBytes repetitions action = do + performGC + !before <- allocated_bytes <$> getRTSStats + !checksum <- repeatMeasuredAction repetitions action + !after <- allocated_bytes <$> getRTSStats + performGC + pure (after - before, checksum) + +repeatMeasuredAction :: Int -> (Int -> IO Int) -> IO Int +repeatMeasuredAction repetitions action = + foldM measureStep 0 [1 .. repetitions] + where + measureStep :: Int -> Int -> IO Int + measureStep !checksum iteration = do + !value <- action iteration + pure (checksum + value) + +{-# NOINLINE freshAllocationWeight #-} +freshAllocationWeight :: Int -> (fixture -> Int) -> fixture -> Int +freshAllocationWeight !iteration weighFixture fixture = + iteration `seq` weighFixture fixture + +{-# NOINLINE allocationBaseline #-} +allocationBaseline :: Int -> Int +allocationBaseline !iteration = + iteration `seq` 1 + +allocationCsv :: [AllocationResult] -> String +allocationCsv results = + unlines + ( "name,gross_allocated_bytes_per_run,baseline_allocated_bytes_per_run,net_allocated_bytes_per_run,repetitions,checksum" + : fmap allocationCsvLine results + ) + +allocationCsvLine :: AllocationResult -> String +allocationCsvLine result = + allocationResultName result + <> "," + <> show (bytesPerRun (allocationResultGrossBytes result) (allocationResultRepetitions result)) + <> "," + <> show (bytesPerRun (allocationResultBaselineBytes result) (allocationResultRepetitions result)) + <> "," + <> show (integerBytesPerRun (allocationResultNetBytes result) (allocationResultRepetitions result)) + <> "," + <> show (allocationResultRepetitions result) + <> "," + <> show (allocationResultChecksum result) + +bytesPerRun :: Word64 -> Int -> Word64 +bytesPerRun bytes repetitions = + bytes `quot` fromIntegral repetitions + +integerBytesPerRun :: Integer -> Int -> Integer +integerBytesPerRun bytes repetitions = + bytes `quot` fromIntegral repetitions diff --git a/bench/patch/Patch/Fixtures.hs b/bench/patch/Patch/Fixtures.hs new file mode 100644 --- /dev/null +++ b/bench/patch/Patch/Fixtures.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE BangPatterns #-} + +module Patch.Fixtures + ( preparePatchComposeFixture, + preparePatchApplyFixture, + preparePatchReplayFixture, + preparePatchDiffFixture, + preparePatchInvertFixture, + patchCanonicalBefore, + patchCanonicalAfter, + patchFromList, + singletonPatch, + recordProducerCells, + replaySequentially, + replayReferenceSequentially, + replayUncheckedSequentially, + applyUncheckedPatch, + patchUncheckedSequentialReplayWeight, + patchDeltaWeight, + patchSupportWeight, + patchProducerWeight, + patchProducerBatchWeight, + patchDiffWeight, + patchInvertWeight, + repeatedPatchInitialState, + scaledRepeatedPatchInitialState, + repeatedPatchStream, + rotatingPatchStream, + expandingPatchStream, + disjointPatchStream, + insertionDeletionPatchStream, + cancellationPatchStream, + stalePatchStreamAt, + olderPatch, + newerPatch, + sparseOlderPatch, + sparseNewerPatch, + overlapPatchComposeFixture, + newerPatchAtRange, + initialPatchState, + largeInitialPatchState, + scaledLargeInitialPatchState, + sparsePatch, + shapeChangingInitialState, + shapeChangingPatch, + patchApplyFailureFixture, + snapshotDiffBeforeState, + snapshotDiffAfterState, + producerCells, + singleCellProducerCells, + absentReplayKeys, + ) +where + +import Control.Monad + ( foldM, + ) +import Data.Map.Strict + ( Map, + ) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import BenchSupport + ( assertBenchmarkAgreement, + benchFailure, + boundedOverlap, + forceBenchmarkFixture, + halfSize, + keys, + mapIntWeight, + repeatedDeltaKeys, + repeatedDeltaSupportSize, + ) +import Patch.Types +import Moonlight.Delta.Patch + ( ApplyError, + CellPatch, + ComposeError, + Patch, + PatchKey, + PatchValue, + ) +import Moonlight.Delta.Patch qualified as Patch +import PatchReference qualified + +preparePatchComposeFixture :: PatchComposeFixture -> IO PatchComposeFixture +preparePatchComposeFixture fixture = + assertBenchmarkAgreement + "patch compose reference/optimized" + (PatchReference.compose (pcfNewer fixture) (pcfOlder fixture)) + (Patch.compose (pcfNewer fixture) (pcfOlder fixture)) + *> forceBenchmarkFixture fixture + +preparePatchApplyFixture :: PatchApplyFixture -> IO PatchApplyFixture +preparePatchApplyFixture fixture = + assertBenchmarkAgreement + "patch apply reference/optimized" + (PatchReference.apply (pafPatch fixture) (pafState fixture)) + (Patch.apply (pafPatch fixture) (pafState fixture)) + *> forceBenchmarkFixture fixture + +preparePatchReplayFixture :: PatchReplayFixture -> IO PatchReplayFixture +preparePatchReplayFixture fixture = + assertBenchmarkAgreement + "patch replay reference/sequential" + (replayReferenceSequentially (prfInitialState fixture) (prfPatches fixture)) + (replaySequentially (prfInitialState fixture) (prfPatches fixture)) + *> assertBenchmarkAgreement + "patch replay reference/fused" + (PatchReference.replay (prfPatches fixture) (prfInitialState fixture)) + (Patch.replay (prfPatches fixture) (prfInitialState fixture)) + *> forceBenchmarkFixture fixture + +preparePatchDiffFixture :: PatchDiffFixture -> IO PatchDiffFixture +preparePatchDiffFixture fixture = + assertBenchmarkAgreement + "patch diff applies" + (Right (pdfAfterState fixture)) + (Patch.apply (Patch.diff (pdfBeforeState fixture) (pdfAfterState fixture)) (pdfBeforeState fixture)) + *> forceBenchmarkFixture fixture + +preparePatchInvertFixture :: PatchInvertFixture -> IO PatchInvertFixture +preparePatchInvertFixture fixture = + assertBenchmarkAgreement + "patch invert applies" + (Right (patchCanonicalBefore (pifPatch fixture))) + (Patch.apply (Patch.invert (pifPatch fixture)) (patchCanonicalAfter (pifPatch fixture))) + *> forceBenchmarkFixture fixture + +recordProducerCells :: + Patch Int Int -> + [(Int, CellPatch Int)] -> + Either (ComposeError Int Int) (Patch Int Int) +recordProducerCells = + foldM recordCell + where + recordCell :: Patch Int Int -> (Int, CellPatch Int) -> Either (ComposeError Int Int) (Patch Int Int) + recordCell !patchValue (key, cell) = + Patch.recordApplied key cell patchValue + +replaySequentially :: + Map Int Int -> + [Patch Int Int] -> + Either (ApplyError Int Int) (Map Int Int) +replaySequentially = + foldM (\ !state patchValue -> Patch.apply patchValue state) + +replayReferenceSequentially :: + Map Int Int -> + [Patch Int Int] -> + Either (ApplyError Int Int) (Map Int Int) +replayReferenceSequentially = + foldM (\ !state patchValue -> PatchReference.apply patchValue state) + +replayUncheckedSequentially :: + Map Int Int -> + [Patch Int Int] -> + Map Int Int +replayUncheckedSequentially = + foldl' (\ !state patchValue -> applyUncheckedPatch patchValue state) + +applyUncheckedPatch :: Patch Int Int -> Map Int Int -> Map Int Int +applyUncheckedPatch patch state = + Patch.foldWithKey' + (\ !updated _key -> updated) + (\ !updated key after -> Map.insert key after updated) + (\ !updated key _before -> Map.delete key updated) + (\ !updated key _before after -> Map.insert key after updated) + state + patch + +patchUncheckedSequentialReplayWeight :: PatchReplayFixture -> Int +patchUncheckedSequentialReplayWeight fixture = + mapIntWeight (replayUncheckedSequentially (prfInitialState fixture) (prfPatches fixture)) + +patchDeltaWeight :: Patch Int Int -> Int +patchDeltaWeight = + Patch.foldWithKey' + (\ !total key -> total + key) + (\ !total key after -> total + key + after) + (\ !total key before -> total + key + before) + (\ !total key before after -> total + key + before + after) + 0 + +patchSupportWeight :: PatchSupportFixture -> Int +patchSupportWeight fixture = + Set.size (Patch.support (psfPatch fixture)) + +patchProducerWeight :: PatchProducerFixture -> Int +patchProducerWeight fixture = + case recordProducerCells Patch.empty (ppfCells fixture) of + Left err -> benchFailure "patch producer accumulation" err + Right patchValue -> patchDeltaWeight patchValue + +patchProducerBatchWeight :: PatchProducerFixture -> Int +patchProducerBatchWeight fixture = + case Patch.recordMany (ppfCells fixture) of + Left err -> benchFailure "patch producer batch accumulation" err + Right patchValue -> patchDeltaWeight patchValue + +patchDiffWeight :: PatchDiffFixture -> Int +patchDiffWeight fixture = + patchDeltaWeight (Patch.diff (pdfBeforeState fixture) (pdfAfterState fixture)) + +patchInvertWeight :: PatchInvertFixture -> Int +patchInvertWeight fixture = + patchDeltaWeight (Patch.invert (pifPatch fixture)) + +singletonPatch :: key -> Maybe value -> Maybe value -> Patch key value +singletonPatch key before after = + Patch.singleton key (Patch.cellFromEndpoints before after) + +patchFromList :: (PatchKey key, PatchValue value) => [(key, CellPatch value)] -> Patch key value +patchFromList = + Patch.fromList + +patchCanonicalBefore :: Patch Int Int -> Map Int Int +patchCanonicalBefore = + Patch.mapMaybeWithKey (\_key cell -> Patch.cellBefore cell) + +patchCanonicalAfter :: Patch Int Int -> Map Int Int +patchCanonicalAfter = + Patch.mapMaybeWithKey (\_key cell -> Patch.cellAfter cell) + +repeatedPatchInitialState :: Int -> Map Int Int +repeatedPatchInitialState = + scaledRepeatedPatchInitialState 1 + +scaledRepeatedPatchInitialState :: Int -> Int -> Map Int Int +scaledRepeatedPatchInitialState stateScale size = + Map.fromAscList + [ (key, repeatedPatchInitialValue key) + | key <- keys (size * 64 * stateScale) + ] + +repeatedPatchInitialValue :: Int -> Int +repeatedPatchInitialValue key + | key < repeatedDeltaSupportSize = 0 + | otherwise = key + +repeatedPatchStream :: Int -> [Patch Int Int] +repeatedPatchStream size = + fmap patchForStep (keys size) + where + patchForStep :: Int -> Patch Int Int + patchForStep step = + patchFromList + [ (key, Patch.replace step (step + 1)) + | key <- repeatedDeltaKeys + ] + +rotatingPatchStream :: Int -> [Patch Int Int] +rotatingPatchStream size = + fmap patchForStep (keys size) + where + patchForStep :: Int -> Patch Int Int + patchForStep step = + singletonPatch + (step `mod` repeatedDeltaSupportSize) + (Just (step `div` repeatedDeltaSupportSize)) + (Just (step `div` repeatedDeltaSupportSize + 1)) + +expandingPatchStream :: Int -> [Patch Int Int] +expandingPatchStream size = + fmap patchForStep (keys size) + where + patchForStep :: Int -> Patch Int Int + patchForStep step = + patchFromList + [ (key, Patch.replace (step - key) (step - key + 1)) + | key <- keys (min repeatedDeltaSupportSize (step + 1)) + ] + +disjointPatchStream :: Int -> [Patch Int Int] +disjointPatchStream size = + fmap patchForStep (keys size) + where + patchForStep :: Int -> Patch Int Int + patchForStep step = + singletonPatch step (Just step) (Just (step + 1)) + +insertionDeletionPatchStream :: Int -> [Patch Int Int] +insertionDeletionPatchStream size = + fmap patchForStep (keys size) + where + patchForStep :: Int -> Patch Int Int + patchForStep step = + patchFromList + [ (key, insertionDeletionCell step) + | key <- absentReplayKeys + ] + + insertionDeletionCell :: Int -> CellPatch Int + insertionDeletionCell step = + if even step + then Patch.insert step + else Patch.delete (step - 1) + +cancellationPatchStream :: Int -> [Patch Int Int] +cancellationPatchStream size = + fmap patchForStep (keys size) + where + patchForStep :: Int -> Patch Int Int + patchForStep step = + patchFromList + [ (key, cancellationCell step) + | key <- repeatedDeltaKeys + ] + + cancellationCell :: Int -> CellPatch Int + cancellationCell step = + if even step + then Patch.replace 0 1 + else Patch.replace 1 0 + +stalePatchStreamAt :: Int -> Int -> [Patch Int Int] +stalePatchStreamAt size failureStep = + fmap patchForStep (keys size) + where + patchForStep :: Int -> Patch Int Int + patchForStep step = + patchFromList + (fmap (patchEntryForStep step) repeatedDeltaKeys) + + patchEntryForStep :: Int -> Int -> (Int, CellPatch Int) + patchEntryForStep step key = + (key, patchCellForStep step) + + patchCellForStep :: Int -> CellPatch Int + patchCellForStep step = + if step == failureStep + then Patch.replace (-1) 0 + else Patch.replace step (step + 1) + +olderPatch :: Int -> Patch Int Int +olderPatch size = + patchFromList + [ (key, Patch.replace key (key + 1)) + | key <- keys size + ] + +newerPatch :: Int -> Patch Int Int +newerPatch size = + patchFromList + [ (key, Patch.replace (key + 1) (key + 2)) + | key <- keys size + ] + +sparseOlderPatch :: Int -> Patch Int Int +sparseOlderPatch _size = + patchFromList + (fmap sparseOlderEntry repeatedDeltaKeys) + where + sparseOlderEntry :: Int -> (Int, CellPatch Int) + sparseOlderEntry key = + (key, Patch.replace key (key + 1)) + +sparseNewerPatch :: Int -> Patch Int Int +sparseNewerPatch _size = + patchFromList + (fmap sparseNewerEntry repeatedDeltaKeys) + where + sparseNewerEntry :: Int -> (Int, CellPatch Int) + sparseNewerEntry key = + (key, Patch.replace (key + 1) (key + 2)) + +overlapPatchComposeFixture :: Int -> Int -> PatchComposeFixture +overlapPatchComposeFixture size requestedOverlap = + PatchComposeFixture + (newerPatchAtRange size (size - boundedOverlap size requestedOverlap)) + (olderPatch size) + +newerPatchAtRange :: Int -> Int -> Patch Int Int +newerPatchAtRange size start = + patchFromList + (fmap newerEntryAt (keys size)) + where + newerEntryAt :: Int -> (Int, CellPatch Int) + newerEntryAt offset = + let key = start + offset + in (key, Patch.replace (key + 1) (key + 2)) + +initialPatchState :: Int -> Map Int Int +initialPatchState size = + Map.fromAscList + [ (key, key) + | key <- keys size + ] + +largeInitialPatchState :: Int -> Map Int Int +largeInitialPatchState = + scaledLargeInitialPatchState 1 + +scaledLargeInitialPatchState :: Int -> Int -> Map Int Int +scaledLargeInitialPatchState stateScale size = + initialPatchState (size * 64 * stateScale) + +sparsePatch :: Int -> Patch Int Int +sparsePatch _size = + patchFromList + [ (key, Patch.replace key (key + 1)) + | key <- repeatedDeltaKeys + ] + +shapeChangingInitialState :: Int -> Map Int Int +shapeChangingInitialState = + initialPatchState + +shapeChangingPatch :: Int -> Patch Int Int +shapeChangingPatch size = + patchFromList (presentEdits <> absentEdits) + where + presentEdits :: [(Int, CellPatch Int)] + presentEdits = + fmap presentShapeEdit (keys size) + + absentEdits :: [(Int, CellPatch Int)] + absentEdits = + fmap absentShapeEdit (keys size) + + presentShapeEdit :: Int -> (Int, CellPatch Int) + presentShapeEdit key = + if even key + then (key, Patch.delete key) + else (key, Patch.replace key (key + 1)) + + absentShapeEdit :: Int -> (Int, CellPatch Int) + absentShapeEdit key = + let absentKey = size + key + in if even key + then (absentKey, Patch.insert key) + else (absentKey, Patch.assertAbsent) + +patchApplyFailureFixture :: Int -> Int -> PatchApplyFixture +patchApplyFailureFixture size failureKey = + PatchApplyFixture + (initialPatchState size) + (patchFromList (fmap patchEntry (keys size))) + where + patchEntry :: Int -> (Int, CellPatch Int) + patchEntry key = + if key == failureKey + then (key, Patch.replace (-1) key) + else (key, Patch.replace key (key + 1)) + +snapshotDiffBeforeState :: Int -> Map Int Int +snapshotDiffBeforeState = + initialPatchState + +snapshotDiffAfterState :: Int -> Map Int Int +snapshotDiffAfterState size = + Map.union + (Map.mapMaybeWithKey changedExistingValue (snapshotDiffBeforeState size)) + (Map.fromAscList (fmap insertedEntry (keys (halfSize size)))) + where + changedExistingValue :: Int -> Int -> Maybe Int + changedExistingValue key value + | key `mod` 4 == 0 = Nothing + | key `mod` 4 == 1 = Just (value + size) + | otherwise = Just value + + insertedEntry :: Int -> (Int, Int) + insertedEntry key = + (size + key, key) + +producerCells :: Int -> [(Int, CellPatch Int)] +producerCells size = + [ (key, Patch.replace step (step + 1)) + | step <- keys size, + key <- repeatedDeltaKeys + ] + +singleCellProducerCells :: Int -> [(Int, CellPatch Int)] +singleCellProducerCells size = + [ (step, Patch.replace step (step + 1)) + | step <- keys size + ] + +absentReplayKeys :: [Int] +absentReplayKeys = + fmap (subtract repeatedDeltaSupportSize) repeatedDeltaKeys diff --git a/bench/patch/Patch/Hackage.hs b/bench/patch/Patch/Hackage.hs new file mode 100644 --- /dev/null +++ b/bench/patch/Patch/Hackage.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE BangPatterns #-} + +module Patch.Hackage + ( prepareHackagePatchComposeFixture, + prepareHackagePatchApplyFixture, + prepareHackagePatchReplayFixture, + hackagePatchComposeConstruct, + hackagePatchApplyConstruct, + hackageReplaySequentially, + hackagePatchMapWeight, + toHackagePatchMap, + hackagePatchMapCompose, + hackagePatchMapApply, + ) +where + +import Control.Exception + ( throwIO, + ) +import Data.Map.Strict + ( Map, + ) +import Data.Map.Strict qualified as Map +import BenchSupport + ( BenchmarkFixtureFailure (..), + assertBenchmarkAgreement, + forceBenchmarkFixture, + maybeIntWeight, + ) +import Patch.Types +import Moonlight.Delta.Patch + ( Patch, + ) +import Moonlight.Delta.Patch qualified as Patch + +prepareHackagePatchComposeFixture :: PatchComposeFixture -> IO HackagePatchComposeFixture +prepareHackagePatchComposeFixture fixture = + case Patch.compose (pcfNewer fixture) (pcfOlder fixture) of + Left err -> + throwIO (BenchmarkFixtureFailure "patch compose hackage projection" (show err)) + Right expectedComposed -> do + let !hackageFixture = + HackagePatchComposeFixture + { hpcfNewer = toHackagePatchMap (pcfNewer fixture), + hpcfOlder = toHackagePatchMap (pcfOlder fixture) + } + assertBenchmarkAgreement + "patch compose hackage projection" + (toHackagePatchMap expectedComposed) + (hackagePatchComposeConstruct hackageFixture) + forceBenchmarkFixture hackageFixture + +prepareHackagePatchApplyFixture :: PatchApplyFixture -> IO HackagePatchApplyFixture +prepareHackagePatchApplyFixture fixture = + case Patch.apply (pafPatch fixture) (pafState fixture) of + Left err -> + throwIO (BenchmarkFixtureFailure "patch apply hackage projection" (show err)) + Right expectedState -> do + let !hackageFixture = + HackagePatchApplyFixture + { hpafState = pafState fixture, + hpafPatch = toHackagePatchMap (pafPatch fixture) + } + assertBenchmarkAgreement + "patch apply hackage projection" + expectedState + (hackagePatchApplyConstruct hackageFixture) + forceBenchmarkFixture hackageFixture + +prepareHackagePatchReplayFixture :: PatchReplayFixture -> IO HackagePatchReplayFixture +prepareHackagePatchReplayFixture fixture = + case Patch.replay (prfPatches fixture) (prfInitialState fixture) of + Left err -> + throwIO (BenchmarkFixtureFailure "patch replay hackage projection" (show err)) + Right expectedState -> do + let !hackageFixture = + HackagePatchReplayFixture + { hprfInitialState = prfInitialState fixture, + hprfPatches = fmap toHackagePatchMap (prfPatches fixture) + } + assertBenchmarkAgreement + "patch replay hackage projection" + expectedState + (hackageReplaySequentially (hprfInitialState hackageFixture) (hprfPatches hackageFixture)) + forceBenchmarkFixture hackageFixture + +{-# NOINLINE hackagePatchComposeConstruct #-} +hackagePatchComposeConstruct :: + HackagePatchComposeFixture -> + HackagePatchMap +hackagePatchComposeConstruct fixture = + hackagePatchMapCompose (hpcfNewer fixture) (hpcfOlder fixture) + +{-# NOINLINE hackagePatchApplyConstruct #-} +hackagePatchApplyConstruct :: + HackagePatchApplyFixture -> + Map Int Int +hackagePatchApplyConstruct fixture = + hackagePatchMapApply (hpafPatch fixture) (hpafState fixture) + +hackageReplaySequentially :: + Map Int Int -> + [HackagePatchMap] -> + Map Int Int +hackageReplaySequentially = + foldl' (\ !state patchValue -> hackagePatchMapApply patchValue state) + +hackagePatchMapWeight :: HackagePatchMap -> Int +hackagePatchMapWeight patchMap = + Map.foldlWithKey' weighEntry 0 (unHackagePatchMap patchMap) + where + weighEntry :: Int -> Int -> Maybe Int -> Int + weighEntry !total key maybeValue = + total + key + maybeIntWeight maybeValue + +toHackagePatchMap :: Patch Int Int -> HackagePatchMap +toHackagePatchMap = + HackagePatchMap + . Map.fromDistinctAscList + . Patch.foldWithKey + (\_key rest -> rest) + (\key after rest -> (key, Just after) : rest) + (\key _before rest -> (key, Nothing) : rest) + (\key _before after rest -> (key, Just after) : rest) + [] + +hackagePatchMapCompose :: HackagePatchMap -> HackagePatchMap -> HackagePatchMap +hackagePatchMapCompose (HackagePatchMap newer) (HackagePatchMap older) = + HackagePatchMap (Map.union newer older) + +hackagePatchMapApply :: HackagePatchMap -> Map Int Int -> Map Int Int +hackagePatchMapApply (HackagePatchMap patchMap) old = + let !insertions = Map.mapMaybe id patchMap + !deletions = Map.mapMaybe hackageDeletion patchMap + in insertions `Map.union` (old `Map.difference` deletions) + +hackageDeletion :: Maybe Int -> Maybe () +hackageDeletion maybeValue = + case maybeValue of + Nothing -> + Just () + Just _ -> + Nothing diff --git a/bench/patch/Patch/Types.hs b/bench/patch/Patch/Types.hs new file mode 100644 --- /dev/null +++ b/bench/patch/Patch/Types.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE BangPatterns #-} + +module Patch.Types + ( PatchComposeFixture (..), + PatchApplyFixture (..), + PatchReplayFixture (..), + HackagePatchMap (..), + HackagePatchComposeFixture (..), + HackagePatchApplyFixture (..), + HackagePatchReplayFixture (..), + PatchDiffFixture (..), + PatchInvertFixture (..), + PatchSupportFixture (..), + PatchProducerFixture (..), + PreparedPatch (..), + PreparedHackagePatchMap (..), + AllocationCase (..), + AllocationResult (..), + PatchComposeImplementation, + PatchApplyImplementation, + rnfPatch, + rnfPatchList, + rnfCellList, + rnfHackagePatchMap, + rnfHackagePatchMapList, + checkedMapMergeLabel, + moonlightPagedPatchLabel, + hackagePatchMapLabel, + moonlightSplitApplyLabel, + checkedSequentialMapMergeLabel, + moonlightSequentialApplyLabel, + moonlightUncheckedSequentialPatchLabel, + hackageSequentialPatchMapLabel, + moonlightFusedReplayLabel, + ) +where + +import Control.DeepSeq + ( NFData (rnf), + ) +import Data.Map.Strict + ( Map, + ) +import Data.Word + ( Word64, + ) +import Moonlight.Delta.Patch + ( ApplyError, + CellPatch, + ComposeError, + Patch, + ) +import Moonlight.Delta.Patch qualified as Patch + +data PatchComposeFixture = PatchComposeFixture + { pcfNewer :: !(Patch Int Int), + pcfOlder :: !(Patch Int Int) + } + +data PatchApplyFixture = PatchApplyFixture + { pafState :: !(Map Int Int), + pafPatch :: !(Patch Int Int) + } + +data PatchReplayFixture = PatchReplayFixture + { prfInitialState :: !(Map Int Int), + prfPatches :: ![Patch Int Int] + } + +-- Benchmark-private projection of Hackage patch-0.0.8.4 Data.Patch.Map: +-- PatchMap k v = Map k (Maybe v), compose is left-biased union, and apply is +-- insertions union (old difference deletions). It cannot represent +-- AssertAbsent or before-value validation, so these rows are unchecked baseline +-- comparisons, not semantic replacements for Patch. +newtype HackagePatchMap = HackagePatchMap + { unHackagePatchMap :: Map Int (Maybe Int) + } + deriving stock (Eq, Show) + +data HackagePatchComposeFixture = HackagePatchComposeFixture + { hpcfNewer :: !HackagePatchMap, + hpcfOlder :: !HackagePatchMap + } + +data HackagePatchApplyFixture = HackagePatchApplyFixture + { hpafState :: !(Map Int Int), + hpafPatch :: !HackagePatchMap + } + +data HackagePatchReplayFixture = HackagePatchReplayFixture + { hprfInitialState :: !(Map Int Int), + hprfPatches :: ![HackagePatchMap] + } + +data PatchDiffFixture = PatchDiffFixture + { pdfBeforeState :: !(Map Int Int), + pdfAfterState :: !(Map Int Int) + } + +newtype PatchInvertFixture = PatchInvertFixture + { pifPatch :: Patch Int Int + } + +newtype PatchSupportFixture = PatchSupportFixture + { psfPatch :: Patch Int Int + } + +newtype PatchProducerFixture = PatchProducerFixture + { ppfCells :: [(Int, CellPatch Int)] + } + +newtype PreparedPatch = PreparedPatch + { preparedPatch :: Patch Int Int + } + +newtype PreparedHackagePatchMap = PreparedHackagePatchMap + { preparedHackagePatchMap :: HackagePatchMap + } + +instance NFData PreparedPatch where + rnf prepared = + rnfPatch (preparedPatch prepared) + +instance NFData PreparedHackagePatchMap where + rnf prepared = + rnfHackagePatchMap (preparedHackagePatchMap prepared) + +data AllocationCase = AllocationCase + { allocationCaseName :: !String, + allocationCaseAction :: !(IO (Int -> IO Int)) + } + +data AllocationResult = AllocationResult + { allocationResultName :: !String, + allocationResultGrossBytes :: !Word64, + allocationResultBaselineBytes :: !Word64, + allocationResultNetBytes :: !Integer, + allocationResultRepetitions :: !Int, + allocationResultChecksum :: !Int + } + +instance NFData PatchComposeFixture where + rnf fixture = + rnfPatch (pcfNewer fixture) + `seq` rnfPatch (pcfOlder fixture) + +instance NFData PatchApplyFixture where + rnf fixture = + rnf (pafState fixture) `seq` rnfPatch (pafPatch fixture) + +instance NFData PatchReplayFixture where + rnf fixture = + rnf (prfInitialState fixture) + `seq` rnfPatchList (prfPatches fixture) + +instance NFData HackagePatchComposeFixture where + rnf fixture = + rnfHackagePatchMap (hpcfNewer fixture) + `seq` rnfHackagePatchMap (hpcfOlder fixture) + +instance NFData HackagePatchApplyFixture where + rnf fixture = + rnf (hpafState fixture) + `seq` rnfHackagePatchMap (hpafPatch fixture) + +instance NFData HackagePatchReplayFixture where + rnf fixture = + rnf (hprfInitialState fixture) + `seq` rnfHackagePatchMapList (hprfPatches fixture) + +instance NFData PatchDiffFixture where + rnf fixture = + rnf (pdfBeforeState fixture) `seq` rnf (pdfAfterState fixture) + +instance NFData PatchInvertFixture where + rnf fixture = + rnfPatch (pifPatch fixture) + +instance NFData PatchSupportFixture where + rnf fixture = + rnfPatch (psfPatch fixture) + +instance NFData PatchProducerFixture where + rnf fixture = + rnfCellList (ppfCells fixture) + +rnfPatch :: Patch Int Int -> () +rnfPatch = + Patch.foldWithKey + (\key rest -> rnf key `seq` rest) + (\key after rest -> rnf key `seq` rnf after `seq` rest) + (\key before rest -> rnf key `seq` rnf before `seq` rest) + (\key before after rest -> rnf key `seq` rnf before `seq` rnf after `seq` rest) + () + +rnfPatchList :: [Patch Int Int] -> () +rnfPatchList = + foldr (\patchValue rest -> rnfPatch patchValue `seq` rest) () + +rnfCellList :: [(Int, CellPatch Int)] -> () +rnfCellList = + foldr rnfCell () + where + rnfCell :: (Int, CellPatch Int) -> () -> () + rnfCell (key, patchValue) rest = + rnf key + `seq` rnf (Patch.cellBefore patchValue) + `seq` rnf (Patch.cellAfter patchValue) + `seq` rest + +rnfHackagePatchMap :: HackagePatchMap -> () +rnfHackagePatchMap patchMap = + rnf (unHackagePatchMap patchMap) + +rnfHackagePatchMapList :: [HackagePatchMap] -> () +rnfHackagePatchMapList = + foldr (\patchMap rest -> rnfHackagePatchMap patchMap `seq` rest) () + +type PatchComposeImplementation = + Patch Int Int -> + Patch Int Int -> + Either (ComposeError Int Int) (Patch Int Int) + +type PatchApplyImplementation = + Patch Int Int -> + Map Int Int -> + Either (ApplyError Int Int) (Map Int Int) + +checkedMapMergeLabel :: String +checkedMapMergeLabel = + "reference: checked Map.mergeA" + +moonlightPagedPatchLabel :: String +moonlightPagedPatchLabel = + "moonlight: paged Patch" + +hackagePatchMapLabel :: String +hackagePatchMapLabel = + "hackage-source: unchecked Data.Patch.Map PatchMap" + +moonlightSplitApplyLabel :: String +moonlightSplitApplyLabel = + "moonlight: split-link Patch.apply" + +checkedSequentialMapMergeLabel :: String +checkedSequentialMapMergeLabel = + "reference: sequential checked Map.mergeA" + +moonlightSequentialApplyLabel :: String +moonlightSequentialApplyLabel = + "moonlight: sequential Patch.apply" + +moonlightUncheckedSequentialPatchLabel :: String +moonlightUncheckedSequentialPatchLabel = + "moonlight: unchecked sequential Patch fold" + +hackageSequentialPatchMapLabel :: String +hackageSequentialPatchMapLabel = + "hackage-source: unchecked sequential Data.Patch.Map" + +moonlightFusedReplayLabel :: String +moonlightFusedReplayLabel = + "moonlight: fused Patch.replay" diff --git a/bench/patch/PatchBench.hs b/bench/patch/PatchBench.hs new file mode 100644 --- /dev/null +++ b/bench/patch/PatchBench.hs @@ -0,0 +1,712 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} + +module PatchBench + ( patchBenchmarks, + patchComposeConstructionAllocationWeight, + patchComposeForcedConstructionWeight, + patchApplyConstructionAllocationWeight, + patchApplyForcedConstructionWeight, + hackagePatchComposeConstructionAllocationWeight, + hackagePatchComposeForcedConstructionWeight, + hackagePatchApplyConstructionAllocationWeight, + hackagePatchApplyForcedConstructionWeight, + preparePatchComposeOutput, + preparePatchApplyOutput, + prepareHackagePatchComposeOutput, + prepareHackagePatchApplyOutput, + patchApplyOutcomeFixtureWeight, + patchApplyReferenceOutcomeFixtureWeight, + patchSequentialReplayWeight, + patchSequentialReplayForcedWeight, + patchSequentialReferenceReplayWeight, + patchSequentialReferenceReplayForcedWeight, + patchSequentialReplayOutcomeWeight, + patchSequentialReferenceReplayOutcomeWeight, + hackagePatchReplayWeight, + hackagePatchReplayForcedWeight, + patchFusedReplayWeight, + patchFusedReplayForcedWeight, + patchFusedReplayOutcomeWeight, + ) +where + +import Control.DeepSeq + ( NFData (rnf), + ) +import Control.Exception + ( evaluate, + throwIO, + ) +import Data.Map.Strict + ( Map, + ) +import Data.Map.Strict qualified as Map +import Moonlight.Core + ( StableHashDigest (..), + StableHashEncoding, + stableHashEncodingChunks, + stableHashEncodingWord64LE, + ) +import BenchSupport + ( BenchmarkFixtureFailure (..), + benchFailure, + caseLabel, + forceBenchmarkFixture, + halfSize, + lastKey, + mapIntWeight, + maybeIntWeight, + middleKey, + patchDeltaSizes, + quarterSize, + ) +import Patch.Fixtures +import Patch.Hackage +import Patch.Types +import Moonlight.Delta.Patch + ( ApplyError (..), + Patch, + ReplayError (..), + ) +import Moonlight.Delta.Patch qualified as Patch +import PatchReference qualified +import Test.Tasty.Bench + ( Benchmark, + bench, + bgroup, + env, + nf, + whnf, + ) + +patchBenchmarks :: Int -> Benchmark +patchBenchmarks stateScale = + bgroup + "patch" + ( (patchDeltaSizes >>= patchBenchmarksForSize stateScale) + <> (deltaHashStateSizes >>= deltaHash128BitRebaselineBenchmarksForSize) + ) + +deltaHashStateSizes :: [Int] +deltaHashStateSizes = + [128, 256, 512, 1024, 2048, 32768, 131072] + +deltaHash128BitRebaselineBenchmarksForSize :: Int -> [Benchmark] +deltaHash128BitRebaselineBenchmarksForSize stateSize = + [ env + (forceBenchmarkFixture (PatchApplyFixture (initialPatchState stateSize) (sparsePatch stateSize))) + ( \fixture -> + bench + (caseLabel "delta hash flat rebuild after sparse checked apply" stateSize) + (nf flatDeltaHashPatchWeight fixture) + ), + env + (prepareMerkleDeltaHashFixture stateSize) + ( \fixture -> + bench + (caseLabel "delta hash adaptive sparse checked apply" stateSize) + (nf adaptiveDeltaHashWeight fixture) + ), + env + (prepareMultisetDeltaHashFixture stateSize) + ( \fixture -> + bench + (caseLabel "delta hash multiset sparse checked apply" stateSize) + (nf multisetDeltaHashWeight fixture) + ) + ] + +data MerkleDeltaHashFixture = MerkleDeltaHashFixture + { merkleDeltaHashFixturePatch :: !(Patch Int Int), + merkleDeltaHashFixtureValue :: !(Patch.MerkleDeltaHash Int Int) + } + +instance NFData MerkleDeltaHashFixture where + rnf fixture = + rnfPatch (merkleDeltaHashFixturePatch fixture) + `seq` rnf (Patch.merkleDeltaHashState (merkleDeltaHashFixtureValue fixture)) + `seq` rnfDigest128 (Patch.merkleDeltaHashDigest (merkleDeltaHashFixtureValue fixture)) + +prepareMerkleDeltaHashFixture :: Int -> IO MerkleDeltaHashFixture +prepareMerkleDeltaHashFixture stateSize = do + fixture <- + forceBenchmarkFixture + (PatchApplyFixture (initialPatchState stateSize) (sparsePatch stateSize)) + case + Patch.buildMerkleDeltaHash + stableHashIntEncoding + stableHashIntEncoding + (pafState fixture) + of + Left err -> + throwIO (BenchmarkFixtureFailure "merkle delta hash fixture" (show err)) + Right merkleDeltaHash -> do + _ <- evaluate (rnfDigest128 (Patch.merkleDeltaHashDigest merkleDeltaHash)) + pure + MerkleDeltaHashFixture + { merkleDeltaHashFixturePatch = pafPatch fixture, + merkleDeltaHashFixtureValue = merkleDeltaHash + } + +data MultisetDeltaHashFixture = MultisetDeltaHashFixture + { multisetDeltaHashFixturePatch :: !(Patch Int Int), + multisetDeltaHashFixtureValue :: !(Patch.MultisetDeltaHash Int Int) + } + +instance NFData MultisetDeltaHashFixture where + rnf fixture = + rnfPatch (multisetDeltaHashFixturePatch fixture) + `seq` rnf (Patch.multisetDeltaHashState (multisetDeltaHashFixtureValue fixture)) + `seq` rnfDigest128 (Patch.multisetDeltaHashDigest (multisetDeltaHashFixtureValue fixture)) + +prepareMultisetDeltaHashFixture :: Int -> IO MultisetDeltaHashFixture +prepareMultisetDeltaHashFixture stateSize = do + fixture <- + forceBenchmarkFixture + (PatchApplyFixture (initialPatchState stateSize) (sparsePatch stateSize)) + let multisetDeltaHash = + Patch.buildMultisetDeltaHash + stableHashIntEncoding + stableHashIntEncoding + (pafState fixture) :: Patch.MultisetDeltaHash Int Int + _ <- evaluate (rnfDigest128 (Patch.multisetDeltaHashDigest multisetDeltaHash)) + pure + MultisetDeltaHashFixture + { multisetDeltaHashFixturePatch = pafPatch fixture, + multisetDeltaHashFixtureValue = multisetDeltaHash + } + +flatDeltaHashPatchWeight :: PatchApplyFixture -> Int +flatDeltaHashPatchWeight fixture = + case Patch.apply (pafPatch fixture) (pafState fixture) of + Left err -> + benchFailure "delta hash flat rebuild" err + Right updatedState -> + case stableHashEncodingChunks stableHashMapEntryEncoding (Map.toAscList updatedState) of + StableHashDigest digest -> + fromIntegral digest + +stableHashMapEntryEncoding :: (Int, Int) -> StableHashEncoding +stableHashMapEntryEncoding (key, value) = + stableHashIntEncoding key + <> stableHashIntEncoding value + +stableHashIntEncoding :: Int -> StableHashEncoding +stableHashIntEncoding = + stableHashEncodingWord64LE . fromIntegral + +adaptiveDeltaHashWeight :: MerkleDeltaHashFixture -> (Int, Int) +adaptiveDeltaHashWeight fixture = + case + Patch.applyMerkleDeltaHash + (merkleDeltaHashFixturePatch fixture) + (merkleDeltaHashFixtureValue fixture) + of + Left err -> + benchFailure "merkle delta hash incremental apply" err + Right updatedMerkleDeltaHash -> + digest128Weight (Patch.merkleDeltaHashDigest updatedMerkleDeltaHash) + +multisetDeltaHashWeight :: MultisetDeltaHashFixture -> (Int, Int) +multisetDeltaHashWeight fixture = + case + Patch.applyMultisetDeltaHash + (multisetDeltaHashFixturePatch fixture) + (multisetDeltaHashFixtureValue fixture) + of + Left err -> + benchFailure "multiset delta hash apply" err + Right updatedMultisetDeltaHash -> + digest128Weight (Patch.multisetDeltaHashDigest updatedMultisetDeltaHash) + +rnfDigest128 :: Patch.Digest128 -> () +rnfDigest128 (Patch.DeltaHashDigest lane0 lane1) = + rnf lane0 `seq` rnf lane1 + +digest128Weight :: Patch.Digest128 -> (Int, Int) +digest128Weight (Patch.DeltaHashDigest lane0 lane1) = + (fromIntegral lane0, fromIntegral lane1) + +patchBenchmarksForSize :: Int -> Int -> [Benchmark] +patchBenchmarksForSize stateScale size = + patchComposeBenchmarksForSize size + <> patchApplyBenchmarksForSize stateScale size + <> patchReplayBenchmarksForSize stateScale size + <> patchDerivedBenchmarksForSize size + +patchComposeBenchmarksForSize :: Int -> [Benchmark] +patchComposeBenchmarksForSize size = + [ env + (preparePatchComposeFixture (overlapPatchComposeFixture size 0)) + (patchComposeBenchGroup "compose overlap none" size), + env + (preparePatchComposeFixture (overlapPatchComposeFixture size (quarterSize size))) + (patchComposeBenchGroup "compose overlap quarter" size), + env + (preparePatchComposeFixture (overlapPatchComposeFixture size (halfSize size))) + (patchComposeBenchGroup "compose overlap half" size), + env + (preparePatchComposeFixture (PatchComposeFixture (newerPatch size) (olderPatch size))) + (patchComposeBenchGroup "compose overlap full" size), + env + (preparePatchComposeFixture (PatchComposeFixture (sparseNewerPatch size) (olderPatch size))) + (patchComposeBenchGroup "compose asymmetric newer sparse" size), + env + (preparePatchComposeFixture (PatchComposeFixture (newerPatch size) (sparseOlderPatch size))) + (patchComposeBenchGroup "compose asymmetric older sparse" size) + ] + +patchApplyBenchmarksForSize :: Int -> Int -> [Benchmark] +patchApplyBenchmarksForSize stateScale size = + [ env + (preparePatchApplyFixture (PatchApplyFixture (initialPatchState size) (olderPatch size))) + (patchApplyBenchGroup "aligned whole checked apply" size), + env + (preparePatchApplyFixture (PatchApplyFixture (scaledLargeInitialPatchState stateScale size) (sparsePatch size))) + (patchApplyBenchGroup "sparse checked apply to large map" size), + env + (preparePatchApplyFixture (PatchApplyFixture (shapeChangingInitialState size) (shapeChangingPatch size))) + (patchApplyBenchGroup "shape-changing assert-absent checked apply" size), + env + (preparePatchApplyFixture (patchApplyFailureFixture size 0)) + (patchApplyOutcomeBenchGroup "apply failure first key" size), + env + (preparePatchApplyFixture (patchApplyFailureFixture size (middleKey size))) + (patchApplyOutcomeBenchGroup "apply failure middle key" size), + env + (preparePatchApplyFixture (patchApplyFailureFixture size (lastKey size))) + (patchApplyOutcomeBenchGroup "apply failure last key" size) + ] + +patchReplayBenchmarksForSize :: Int -> Int -> [Benchmark] +patchReplayBenchmarksForSize stateScale size = + [ patchReplayBenchmark + "stable sparse replay over large map" + size + (PatchReplayFixture (scaledRepeatedPatchInitialState stateScale size) (repeatedPatchStream size)), + patchReplayBenchmark + "rotating sparse replay over large map" + size + (PatchReplayFixture (scaledRepeatedPatchInitialState stateScale size) (rotatingPatchStream size)), + patchReplayBenchmark + "expanding sparse replay over large map" + size + (PatchReplayFixture (scaledRepeatedPatchInitialState stateScale size) (expandingPatchStream size)), + patchReplayBenchmark + "disjoint sparse replay over large map" + size + (PatchReplayFixture (scaledLargeInitialPatchState stateScale size) (disjointPatchStream size)), + patchReplayBenchmark + "insertion-deletion replay over large map" + size + (PatchReplayFixture (scaledLargeInitialPatchState stateScale size) (insertionDeletionPatchStream size)), + patchReplayBenchmark + "cancellation replay over large map" + size + (PatchReplayFixture (scaledRepeatedPatchInitialState stateScale size) (cancellationPatchStream size)), + patchStaleReplayBenchmark + "stale-at-first replay over large map" + size + (PatchReplayFixture (scaledRepeatedPatchInitialState stateScale size) (stalePatchStreamAt size 0)), + patchStaleReplayBenchmark + "stale-at-middle replay over large map" + size + (PatchReplayFixture (scaledRepeatedPatchInitialState stateScale size) (stalePatchStreamAt size (middleKey size))), + patchStaleReplayBenchmark + "stale-at-last replay over large map" + size + (PatchReplayFixture (scaledRepeatedPatchInitialState stateScale size) (stalePatchStreamAt size (lastKey size))) + ] + +patchDerivedBenchmarksForSize :: Int -> [Benchmark] +patchDerivedBenchmarksForSize size = + [ env + (preparePatchDiffFixture (PatchDiffFixture (snapshotDiffBeforeState size) (snapshotDiffAfterState size))) + (bench (caseLabel "snapshot diff" size) . nf patchDiffWeight), + env + (preparePatchInvertFixture (PatchInvertFixture (shapeChangingPatch size))) + (bench (caseLabel "invert insertion deletion patch" size) . nf patchInvertWeight), + env + (forceBenchmarkFixture (PatchSupportFixture (olderPatch size))) + (bench (caseLabel "support materialization" size) . nf patchSupportWeight), + env + (forceBenchmarkFixture (PatchProducerFixture (producerCells size))) + (bench (caseLabel "repeated-key temporal recording one-by-one" size) . nf patchProducerWeight), + env + (forceBenchmarkFixture (PatchProducerFixture (singleCellProducerCells size))) + (bench (caseLabel "recordApplied single-cell producer" size) . nf patchProducerWeight), + env + (forceBenchmarkFixture (PatchProducerFixture (producerCells size))) + (bench (caseLabel "repeated-key temporal recording batch" size) . nf patchProducerBatchWeight) + ] + +patchComposeBenchGroup :: String -> Int -> PatchComposeFixture -> Benchmark +patchComposeBenchGroup label size fixture = + bgroup + (caseLabel label size) + [ patchComposeVariantBenchGroup checkedMapMergeLabel PatchReference.compose fixture, + patchComposeVariantBenchGroup moonlightPagedPatchLabel Patch.compose fixture, + env + (prepareHackagePatchComposeFixture fixture) + (hackagePatchComposeVariantBenchGroup hackagePatchMapLabel) + ] + +patchComposeVariantBenchGroup :: + String -> + PatchComposeImplementation -> + PatchComposeFixture -> + Benchmark +patchComposeVariantBenchGroup variant implementation fixture = + bgroup + variant + [ bench "construct" (whnf (patchComposeConstructWith implementation) fixture), + bench "construct forced" (nf (patchComposeForcedConstructionWeight implementation) fixture), + env + (preparePatchComposeOutput variant implementation fixture) + (\composed -> bench "consume" (nf (patchDeltaWeight . preparedPatch) composed)) + ] + +{-# NOINLINE patchComposeConstructWith #-} +patchComposeConstructWith :: + PatchComposeImplementation -> + PatchComposeFixture -> + Patch Int Int +patchComposeConstructWith implementation fixture = + case implementation (pcfNewer fixture) (pcfOlder fixture) of + Left err -> + benchFailure "patch compose construction" err + Right !composed -> + composed + +preparePatchComposeOutput :: + String -> + PatchComposeImplementation -> + PatchComposeFixture -> + IO PreparedPatch +preparePatchComposeOutput variant implementation fixture = + case implementation (pcfNewer fixture) (pcfOlder fixture) of + Left err -> + throwIO (BenchmarkFixtureFailure ("patch compose output: " <> variant) (show err)) + Right !composed -> do + evaluate (rnfPatch composed) + pure (PreparedPatch composed) + +hackagePatchComposeVariantBenchGroup :: + String -> + HackagePatchComposeFixture -> + Benchmark +hackagePatchComposeVariantBenchGroup variant fixture = + bgroup + variant + [ bench "construct" (whnf hackagePatchComposeConstruct fixture), + bench "construct forced" (nf hackagePatchComposeForcedConstructionWeight fixture), + env + (prepareHackagePatchComposeOutput variant fixture) + (\composed -> bench "consume" (nf (hackagePatchMapWeight . preparedHackagePatchMap) composed)) + ] + +prepareHackagePatchComposeOutput :: + String -> + HackagePatchComposeFixture -> + IO PreparedHackagePatchMap +prepareHackagePatchComposeOutput variant fixture = do + let !composed = hackagePatchComposeConstruct fixture + evaluate (rnfHackagePatchMap composed) + variant `seq` pure (PreparedHackagePatchMap composed) + +patchApplyBenchGroup :: String -> Int -> PatchApplyFixture -> Benchmark +patchApplyBenchGroup label size fixture = + bgroup + (caseLabel label size) + [ patchApplyVariantBenchGroup checkedMapMergeLabel PatchReference.apply fixture, + patchApplyVariantBenchGroup moonlightPagedPatchLabel Patch.apply fixture, + env + (prepareHackagePatchApplyFixture fixture) + (hackagePatchApplyVariantBenchGroup hackagePatchMapLabel) + ] + +patchApplyVariantBenchGroup :: + String -> + PatchApplyImplementation -> + PatchApplyFixture -> + Benchmark +patchApplyVariantBenchGroup variant implementation fixture = + bgroup + variant + [ bench "construct" (whnf (patchApplyConstructWith implementation) fixture), + bench "construct forced" (nf (patchApplyForcedConstructionWeight implementation) fixture), + env + (preparePatchApplyOutput variant implementation fixture) + (\updatedState -> bench "consume" (nf mapIntWeight updatedState)) + ] + +{-# NOINLINE patchApplyConstructWith #-} +patchApplyConstructWith :: + PatchApplyImplementation -> + PatchApplyFixture -> + Map Int Int +patchApplyConstructWith implementation fixture = + case implementation (pafPatch fixture) (pafState fixture) of + Left err -> + benchFailure "patch apply construction" err + Right !updatedState -> + updatedState + +preparePatchApplyOutput :: + String -> + PatchApplyImplementation -> + PatchApplyFixture -> + IO (Map Int Int) +preparePatchApplyOutput variant implementation fixture = + case implementation (pafPatch fixture) (pafState fixture) of + Left err -> + throwIO (BenchmarkFixtureFailure ("patch apply output: " <> variant) (show err)) + Right !updatedState -> do + evaluate (rnf updatedState) + pure updatedState + +hackagePatchApplyVariantBenchGroup :: + String -> + HackagePatchApplyFixture -> + Benchmark +hackagePatchApplyVariantBenchGroup variant fixture = + bgroup + variant + [ bench "construct" (whnf hackagePatchApplyConstruct fixture), + bench "construct forced" (nf hackagePatchApplyForcedConstructionWeight fixture), + env + (prepareHackagePatchApplyOutput variant fixture) + (\updatedState -> bench "consume" (nf mapIntWeight updatedState)) + ] + +prepareHackagePatchApplyOutput :: + String -> + HackagePatchApplyFixture -> + IO (Map Int Int) +prepareHackagePatchApplyOutput variant fixture = do + let !updatedState = hackagePatchApplyConstruct fixture + evaluate (rnf updatedState) + variant `seq` pure updatedState + +patchApplyOutcomeBenchGroup :: String -> Int -> PatchApplyFixture -> Benchmark +patchApplyOutcomeBenchGroup label size fixture = + bgroup + (caseLabel label size) + [ bench checkedMapMergeLabel (nf patchApplyReferenceOutcomeFixtureWeight fixture), + bench moonlightSplitApplyLabel (nf patchApplyOutcomeFixtureWeight fixture) + ] + +patchReplayBenchmark :: + String -> + Int -> + PatchReplayFixture -> + Benchmark +patchReplayBenchmark label size replayFixture = + env + (preparePatchReplayFixture replayFixture) + ( \fixture -> + bgroup + (caseLabel label size) + [ bench checkedSequentialMapMergeLabel (nf patchSequentialReferenceReplayWeight fixture), + bench (forcedVariantName checkedSequentialMapMergeLabel) (nf patchSequentialReferenceReplayForcedWeight fixture), + bench moonlightSequentialApplyLabel (nf patchSequentialReplayWeight fixture), + bench (forcedVariantName moonlightSequentialApplyLabel) (nf patchSequentialReplayForcedWeight fixture), + bench moonlightUncheckedSequentialPatchLabel (nf patchUncheckedSequentialReplayWeight fixture), + env + (prepareHackagePatchReplayFixture fixture) + (\hackageFixture -> bench hackageSequentialPatchMapLabel (nf hackagePatchReplayWeight hackageFixture)), + env + (prepareHackagePatchReplayFixture fixture) + (\hackageFixture -> bench (forcedVariantName hackageSequentialPatchMapLabel) (nf hackagePatchReplayForcedWeight hackageFixture)), + bench moonlightFusedReplayLabel (nf patchFusedReplayWeight fixture), + bench (forcedVariantName moonlightFusedReplayLabel) (nf patchFusedReplayForcedWeight fixture) + ] + ) + +patchStaleReplayBenchmark :: + String -> + Int -> + PatchReplayFixture -> + Benchmark +patchStaleReplayBenchmark label size replayFixture = + env + (preparePatchReplayFixture replayFixture) + ( \fixture -> + bgroup + (caseLabel label size) + [ bench checkedSequentialMapMergeLabel (nf patchSequentialReferenceReplayOutcomeWeight fixture), + bench moonlightSequentialApplyLabel (nf patchSequentialReplayOutcomeWeight fixture), + bench moonlightFusedReplayLabel (nf patchFusedReplayOutcomeWeight fixture) + ] + ) + +patchApplyOutcomeFixtureWeight :: PatchApplyFixture -> Int +patchApplyOutcomeFixtureWeight fixture = + patchApplyOutcomeWeight (Patch.apply (pafPatch fixture) (pafState fixture)) + +patchApplyReferenceOutcomeFixtureWeight :: PatchApplyFixture -> Int +patchApplyReferenceOutcomeFixtureWeight fixture = + patchApplyOutcomeWeight (PatchReference.apply (pafPatch fixture) (pafState fixture)) + +patchSequentialReplayWeight :: PatchReplayFixture -> Int +patchSequentialReplayWeight fixture = + case replaySequentially (prfInitialState fixture) (prfPatches fixture) of + Left err -> benchFailure "patch sequential replay" err + Right finalState -> mapIntWeight finalState + +patchSequentialReplayForcedWeight :: PatchReplayFixture -> Int +patchSequentialReplayForcedWeight fixture = + case replaySequentially (prfInitialState fixture) (prfPatches fixture) of + Left err -> benchFailure "patch sequential replay forced" err + Right finalState -> rnf finalState `seq` 1 + +patchSequentialReferenceReplayWeight :: PatchReplayFixture -> Int +patchSequentialReferenceReplayWeight fixture = + case replayReferenceSequentially (prfInitialState fixture) (prfPatches fixture) of + Left err -> benchFailure "patch sequential reference replay" err + Right finalState -> mapIntWeight finalState + +patchSequentialReferenceReplayForcedWeight :: PatchReplayFixture -> Int +patchSequentialReferenceReplayForcedWeight fixture = + case replayReferenceSequentially (prfInitialState fixture) (prfPatches fixture) of + Left err -> benchFailure "patch sequential reference replay forced" err + Right finalState -> rnf finalState `seq` 1 + +patchSequentialReplayOutcomeWeight :: PatchReplayFixture -> Int +patchSequentialReplayOutcomeWeight fixture = + patchReplayOutcomeWeight + (replaySequentially (prfInitialState fixture) (prfPatches fixture)) + +patchSequentialReferenceReplayOutcomeWeight :: PatchReplayFixture -> Int +patchSequentialReferenceReplayOutcomeWeight fixture = + patchReplayOutcomeWeight + (replayReferenceSequentially (prfInitialState fixture) (prfPatches fixture)) + +hackagePatchReplayWeight :: HackagePatchReplayFixture -> Int +hackagePatchReplayWeight fixture = + mapIntWeight + (hackageReplaySequentially (hprfInitialState fixture) (hprfPatches fixture)) + +hackagePatchReplayForcedWeight :: HackagePatchReplayFixture -> Int +hackagePatchReplayForcedWeight fixture = + rnf (hackageReplaySequentially (hprfInitialState fixture) (hprfPatches fixture)) `seq` 1 + +patchFusedReplayWeight :: PatchReplayFixture -> Int +patchFusedReplayWeight fixture = + case Patch.replay (prfPatches fixture) (prfInitialState fixture) of + Left err -> benchFailure "patch fused replay" err + Right finalState -> mapIntWeight finalState + +patchFusedReplayForcedWeight :: PatchReplayFixture -> Int +patchFusedReplayForcedWeight fixture = + case Patch.replay (prfPatches fixture) (prfInitialState fixture) of + Left err -> benchFailure "patch fused replay forced" err + Right finalState -> rnf finalState `seq` 1 + +patchFusedReplayOutcomeWeight :: PatchReplayFixture -> Int +patchFusedReplayOutcomeWeight fixture = + patchFusedReplayOutcomeWeightFromResult + (Patch.replay (prfPatches fixture) (prfInitialState fixture)) + +patchReplayOutcomeWeight :: + Either (ApplyError Int Int) (Map Int Int) -> + Int +patchReplayOutcomeWeight outcome = + case outcome of + Left err -> + patchApplyErrorWeight err + Right finalState -> + mapIntWeight finalState + +patchApplyOutcomeWeight :: + Either (ApplyError Int Int) (Map Int Int) -> + Int +patchApplyOutcomeWeight outcome = + case outcome of + Left err -> + patchApplyErrorWeight err + Right finalState -> + mapIntWeight finalState + +patchFusedReplayOutcomeWeightFromResult :: + Either (ReplayError Int Int) (Map Int Int) -> + Int +patchFusedReplayOutcomeWeightFromResult outcome = + case outcome of + Left err -> + fromIntegral (replayIndex err) + patchApplyErrorWeight (replayApply err) + Right finalState -> + mapIntWeight finalState + +patchApplyErrorWeight :: + ApplyError Int Int -> + Int +patchApplyErrorWeight err = + mismatchKey err + + maybeIntWeight (expectedBefore err) + + maybeIntWeight (actualBefore err) + +patchComposeConstructionAllocationWeight :: + PatchComposeImplementation -> + PatchComposeFixture -> + Int +patchComposeConstructionAllocationWeight implementation fixture = + let !composed = patchComposeConstructWith implementation fixture + in composed `seq` 1 + +patchComposeForcedConstructionWeight :: + PatchComposeImplementation -> + PatchComposeFixture -> + Int +patchComposeForcedConstructionWeight implementation fixture = + let !composed = patchComposeConstructWith implementation fixture + in rnfPatch composed `seq` 1 + +patchApplyForcedConstructionWeight :: + PatchApplyImplementation -> + PatchApplyFixture -> + Int +patchApplyForcedConstructionWeight implementation fixture = + let !updatedState = patchApplyConstructWith implementation fixture + in rnf updatedState `seq` 1 + +patchApplyConstructionAllocationWeight :: + PatchApplyImplementation -> + PatchApplyFixture -> + Int +patchApplyConstructionAllocationWeight implementation fixture = + let !updatedState = patchApplyConstructWith implementation fixture + in updatedState `seq` 1 + +hackagePatchComposeConstructionAllocationWeight :: + HackagePatchComposeFixture -> + Int +hackagePatchComposeConstructionAllocationWeight fixture = + let !composed = hackagePatchComposeConstruct fixture + in composed `seq` 1 + +hackagePatchComposeForcedConstructionWeight :: + HackagePatchComposeFixture -> + Int +hackagePatchComposeForcedConstructionWeight fixture = + let !composed = hackagePatchComposeConstruct fixture + in rnfHackagePatchMap composed `seq` 1 + +hackagePatchApplyForcedConstructionWeight :: + HackagePatchApplyFixture -> + Int +hackagePatchApplyForcedConstructionWeight fixture = + let !updatedState = hackagePatchApplyConstruct fixture + in rnf updatedState `seq` 1 + +hackagePatchApplyConstructionAllocationWeight :: + HackagePatchApplyFixture -> + Int +hackagePatchApplyConstructionAllocationWeight fixture = + let !updatedState = hackagePatchApplyConstruct fixture + in updatedState `seq` 1 + +forcedVariantName :: String -> String +forcedVariantName variant = + variant <> ".construct forced" diff --git a/bench/repair/Main.hs b/bench/repair/Main.hs new file mode 100644 --- /dev/null +++ b/bench/repair/Main.hs @@ -0,0 +1,13 @@ +module Main + ( main, + ) +where + +import RepairBench + ( repairBenchmarks, + ) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [repairBenchmarks] diff --git a/bench/repair/RepairBench.hs b/bench/repair/RepairBench.hs new file mode 100644 --- /dev/null +++ b/bench/repair/RepairBench.hs @@ -0,0 +1,113 @@ +module RepairBench + ( repairBenchmarks, + ) +where + +import Data.List.NonEmpty + ( NonEmpty (..), + ) +import BenchSupport + ( caseLabel, + naturalWeight, + repairSizes, + ) +import Moonlight.Delta.Repair + ( Config (..), + Kernel (..), + Result (..), + Round, + Step (..), + Trace (..), + boundedRepair, + boundedRepairTraced, + applied, + irreducible, + obstructions, + ) +import Test.Tasty.Bench + ( Benchmark, + bench, + bgroup, + nf, + ) + +data RepairObstruction = BelowTarget !Int + deriving stock (Eq, Show) + +data Correction = AddChunk !Int + deriving stock (Eq, Show) + +repairBenchmarks :: Benchmark +repairBenchmarks = + bgroup + "repair" + (repairSizes >>= repairBenchmarksForSize) + +repairBenchmarksForSize :: Int -> [Benchmark] +repairBenchmarksForSize target = + [ bench (caseLabel "boundedRepair" target) (nf repairResultWeight target), + bench (caseLabel "boundedRepairTraced" target) (nf repairTraceWeight target) + ] + +repairResultWeight :: Int -> Int +repairResultWeight target = + repairResultScore (boundedRepair (repairKernel target) (repairConfig target) 0) + +repairTraceWeight :: Int -> Int +repairTraceWeight target = + let (result, traceValue) = boundedRepairTraced (repairKernel target) (repairConfig target) 0 + in repairResultScore result + repairTraceScore traceValue + +repairResultScore :: Result Int RepairObstruction -> Int +repairResultScore result = + case result of + ResultConverged stateValue rounds -> stateValue + naturalWeight rounds + ResultStuck stateValue obstructionValues rounds -> stateValue + obstructionWeight obstructionValues + naturalWeight rounds + ResultBudgetExhausted stateValue obstructionValues rounds -> stateValue + obstructionWeight obstructionValues + naturalWeight rounds + +repairTraceScore :: Trace RepairObstruction Correction -> Int +repairTraceScore (Trace rounds) = + sum (fmap repairRoundScore rounds) + +repairRoundScore :: Round RepairObstruction Correction -> Int +repairRoundScore roundValue = + obstructionWeight (obstructions roundValue) + + naturalWeight (applied roundValue) + + length (irreducible roundValue) + +repairKernel :: Int -> Kernel Int RepairObstruction Correction +repairKernel target = + Kernel + { check = inspectRepairState target, + residuate = proposeRepairCorrection target, + applyKernelCorrection = applyRepairCorrection target + } + +inspectRepairState :: Int -> Int -> Step Int RepairObstruction +inspectRepairState target stateValue + | stateValue >= target = StepConverged stateValue + | otherwise = StepObstructed stateValue (BelowTarget target :| []) + +proposeRepairCorrection :: Int -> RepairObstruction -> Maybe Correction +proposeRepairCorrection target obstruction = + case obstruction of + BelowTarget _ -> Just (AddChunk (repairChunk target)) + +applyRepairCorrection :: Int -> Int -> Correction -> Int +applyRepairCorrection target stateValue correction = + case correction of + AddChunk chunk -> min target (stateValue + chunk) + +repairChunk :: Int -> Int +repairChunk target = + max 1 (target `div` 16) + +repairConfig :: Int -> Config +repairConfig target = + Config + { maxRounds = fromIntegral target + } + +obstructionWeight :: NonEmpty RepairObstruction -> Int +obstructionWeight = + sum . fmap (\(BelowTarget target) -> target) diff --git a/bench/support/BenchSupport.hs b/bench/support/BenchSupport.hs new file mode 100644 --- /dev/null +++ b/bench/support/BenchSupport.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE BangPatterns #-} + +module BenchSupport + ( BenchmarkFixtureFailure (..), + benchFailure, + forceBenchmarkFixture, + assertBenchmarkAgreement, + keys, + lastKey, + middleKey, + halfSize, + quarterSize, + boundedOverlap, + patchDeltaSizes, + readStateScale, + defaultAllocationRepetitions, + deltaSizes, + frontierSizes, + frontierDominatedSizes, + repairSizes, + repeatedDeltaKeys, + repeatedDeltaSupportSize, + caseLabel, + mapIntWeight, + maybeIntWeight, + naturalWeight, + ) +where + +import Control.DeepSeq + ( NFData (rnf), + ) +import Control.Exception + ( Exception, + evaluate, + throw, + ) +import Data.Map.Strict + ( Map, + ) +import Data.Map.Strict qualified as Map +import Numeric.Natural + ( Natural, + ) +import System.Environment + ( lookupEnv, + ) +import Text.Read + ( readMaybe, + ) + +data BenchmarkFixtureFailure = BenchmarkFixtureFailure + { benchmarkFixtureFailureLabel :: !String, + benchmarkFixtureFailureDetail :: !String + } + deriving stock (Show) + +instance Exception BenchmarkFixtureFailure + +benchFailure :: Show err => String -> err -> result +benchFailure label err = + throw (BenchmarkFixtureFailure label (show err)) + +forceBenchmarkFixture :: NFData fixture => fixture -> IO fixture +forceBenchmarkFixture fixture = + evaluate (rnf fixture) *> pure fixture + +assertBenchmarkAgreement :: + (Eq result, Show result) => + String -> + result -> + result -> + IO () +assertBenchmarkAgreement label expected actual = + if expected == actual + then pure () + else + throw + ( BenchmarkFixtureFailure + label + ("reference: " <> show expected <> "; optimized: " <> show actual) + ) + +keys :: Int -> [Int] +keys size = [0 .. size - 1] + +lastKey :: Int -> Int +lastKey size = + max 0 (size - 1) + +middleKey :: Int -> Int +middleKey size = + min (lastKey size) (max 0 (size `div` 2)) + +halfSize :: Int -> Int +halfSize size = + max 1 (size `div` 2) + +quarterSize :: Int -> Int +quarterSize size = + max 1 (size `div` 4) + +boundedOverlap :: Int -> Int -> Int +boundedOverlap size requestedOverlap = + max 0 (min size requestedOverlap) + +patchDeltaSizes :: [Int] +patchDeltaSizes = [1, 2, 4, 8, 16, 32, 63, 64, 65, 128, 512, 2048, 8192] + +readStateScale :: IO Int +readStateScale = do + raw <- lookupEnv "MOONLIGHT_DELTA_STATE_SCALE" + pure (maybe 1 (max 1) (raw >>= readMaybe)) + +defaultAllocationRepetitions :: Int +defaultAllocationRepetitions = 16 + +deltaSizes :: [Int] +deltaSizes = [128, 512, 2048] + +frontierSizes :: [Int] +frontierSizes = [64, 256, 1024] + +frontierDominatedSizes :: [Int] +frontierDominatedSizes = [64, 256] + +repairSizes :: [Int] +repairSizes = [128, 512, 2048] + +repeatedDeltaKeys :: [Int] +repeatedDeltaKeys = + keys repeatedDeltaSupportSize + +repeatedDeltaSupportSize :: Int +repeatedDeltaSupportSize = + 32 + +caseLabel :: String -> Int -> String +caseLabel label size = + label <> " n=" <> show size + +mapIntWeight :: Map Int Int -> Int +mapIntWeight = + Map.foldlWithKey' weighEntry 0 + where + weighEntry :: Int -> Int -> Int -> Int + weighEntry !total key value = + total + key + value + +maybeIntWeight :: Maybe Int -> Int +maybeIntWeight maybeValue = + case maybeValue of + Nothing -> + 0 + Just value -> + value + +naturalWeight :: Natural -> Int +naturalWeight = + fromIntegral diff --git a/moonlight-delta.cabal b/moonlight-delta.cabal new file mode 100644 --- /dev/null +++ b/moonlight-delta.cabal @@ -0,0 +1,416 @@ +cabal-version: 3.0 +name: moonlight-delta +version: 0.1.0.0 +synopsis: Boundary-aware delta calculus for Moonlight. +description: Categorical and state-change delta vocabulary layered over moonlight-core. +license: MIT +license-file: LICENSE +author: Blue Rose +maintainer: rosaliafialkova@gmail.com +category: Math +homepage: https://github.com/PaleRoses/moonlight +bug-reports: https://github.com/PaleRoses/moonlight/issues +build-type: Simple +tested-with: GHC == 9.14.1 +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/PaleRoses/moonlight.git + subdir: moonlight-delta + +common shared-properties + default-language: GHC2024 + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wpartial-fields + -Wno-missing-import-lists + default-extensions: + StrictData + NoImplicitPrelude + TypeFamilies + UndecidableInstances + +library moonlight-delta-core + import: shared-properties + visibility: public + hs-source-dirs: src-core + exposed-modules: + Moonlight.Delta.Frontier + Moonlight.Delta.Monotone + Moonlight.Delta.Normalize + Moonlight.Delta.Operator + Moonlight.Delta.Scope + Moonlight.Delta.Signed + Moonlight.Delta.Support + Moonlight.Delta.Time + build-depends: + base >= 4.22 && < 5 + , containers >= 0.8 && < 0.9 + , moonlight-core >= 0.1 && < 0.2 + , vector >= 0.13 && < 0.14 + +library moonlight-delta-patch-internal + import: shared-properties + visibility: private + hs-source-dirs: src-patch + exposed-modules: + Moonlight.Delta.Patch.Internal.Apply + Moonlight.Delta.Patch.Internal.Builder + Moonlight.Delta.Patch.Internal.Cell + Moonlight.Delta.Patch.Internal.Compose.Core + Moonlight.Delta.Patch.Internal.Compose.Record + Moonlight.Delta.Patch.Internal.Construction + Moonlight.Delta.Patch.Internal.IncrementalDigest + Moonlight.Delta.Patch.Internal.MerkleDeltaHash + Moonlight.Delta.Patch.Internal.MultisetDeltaHash + Moonlight.Delta.Patch.Internal.NodeCommitment + Moonlight.Delta.Patch.Internal.Replay + Moonlight.Delta.Patch.Internal.Types + other-modules: + Moonlight.Delta.Patch.Internal.Compose.Aligned + Moonlight.Delta.Patch.Internal.Compose.Range + Moonlight.Delta.Patch.Internal.Compose.SameSupport + Moonlight.Delta.Patch.Internal.Cursor + Moonlight.Delta.Patch.Internal.Page + build-depends: + base >= 4.22 && < 5 + , containers >= 0.8 && < 0.9 + , moonlight-algebra:abstract >= 0.1 && < 0.2 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-delta:moonlight-delta-core + , primitive >= 0.9 && < 0.10 + , vector >= 0.13 && < 0.14 + +library moonlight-delta-patch + import: shared-properties + visibility: public + hs-source-dirs: src-patch-public + exposed-modules: + Moonlight.Delta.Patch + build-depends: + base >= 4.22 && < 5 + , moonlight-delta:moonlight-delta-patch-internal + +library moonlight-delta-epoch + import: shared-properties + visibility: public + hs-source-dirs: src-epoch + exposed-modules: + Moonlight.Delta.Epoch + other-modules: + Moonlight.Delta.Epoch.Internal.Compose + Moonlight.Delta.Epoch.Internal.Construction + Moonlight.Delta.Epoch.Internal.Projection + Moonlight.Delta.Epoch.Internal.Transport + Moonlight.Delta.Epoch.Internal.Types + Moonlight.Delta.Epoch.Internal.Version + Moonlight.Delta.Epoch.Internal.View + build-depends: + base >= 4.22 && < 5 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-delta:moonlight-delta-core + +library moonlight-delta-repair + import: shared-properties + visibility: public + hs-source-dirs: src-repair + exposed-modules: + Moonlight.Delta.Repair + build-depends: + base >= 4.22 && < 5 + +common moonlight-delta-test-properties + default-language: GHC2024 + ghc-options: -Wall -Wcompat + default-extensions: + TypeFamilies + build-depends: + base >= 4.22 && < 5 + , tasty >= 1.4 + +test-suite moonlight-delta-core-test + import: moonlight-delta-test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + test/core + test-support + main-is: Main.hs + other-modules: + CoreTests + DeltaLaws + LawManifest + build-depends: + containers >= 0.8 && < 0.9 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-delta:moonlight-delta-core + , tasty-hunit >= 0.10 + , tasty-quickcheck >= 0.10 + , QuickCheck >= 2.14 + +test-suite moonlight-delta-patch-test + import: moonlight-delta-test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + test/patch + test-support + main-is: Main.hs + other-modules: + CodecSpec + DeltaLaws + LawManifest + LawsSpec + PatchReference + PatchLaws + PatchSupport + PatchTests + ReferenceSpec + ReplaySpec + SemanticsSpec + DeltaHashSpec + build-depends: + containers >= 0.8 && < 0.9 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-delta:moonlight-delta-core + , moonlight-delta:moonlight-delta-patch-internal + , moonlight-delta:moonlight-delta-patch + , tasty-hunit >= 0.10 + , tasty-quickcheck >= 0.10 + , QuickCheck >= 2.14 + +test-suite moonlight-delta-epoch-test + import: moonlight-delta-test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + test/epoch + test-support + main-is: Main.hs + other-modules: + ComposeSpec + ConstructionSpec + EpochSupport.Expected + EpochSupport.Generators + EpochSupport.Mapping + EpochSupport.Reference + EpochSupport.Types + EpochTests + FiniteSpec + LawManifest + ProjectionSpec + TransportSpec + VersionSpec + ViewSpec + build-depends: + containers >= 0.8 && < 0.9 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-delta:moonlight-delta-core + , moonlight-delta:moonlight-delta-epoch + , tasty-hunit >= 0.10 + , tasty-quickcheck >= 0.10 + , QuickCheck >= 2.14 + +test-suite moonlight-delta-repair-test + import: moonlight-delta-test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: test/repair + main-is: Main.hs + other-modules: + RepairTests + build-depends: + moonlight-delta:moonlight-delta-repair + , tasty-hunit >= 0.10 + +test-suite moonlight-delta-laws-test + import: moonlight-delta-test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + test/laws + test/patch + test/epoch + test-support + main-is: Main.hs + other-modules: + CrossCarrierLaws + DeltaLaws + EpochSupport.Generators + EpochSupport.Types + LawManifest + PatchSupport + PatchLaws + build-depends: + containers >= 0.8 && < 0.9 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-delta:moonlight-delta-core + , moonlight-delta:moonlight-delta-epoch + , moonlight-delta:moonlight-delta-patch + , tasty-hunit >= 0.10 + , tasty-quickcheck >= 0.10 + , QuickCheck >= 2.14 + +test-suite moonlight-delta-test + import: moonlight-delta-test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + test/aggregate + test/core + test/patch + test/epoch + test/repair + test/laws + test-support + main-is: Main.hs + other-modules: + CodecSpec + ComposeSpec + ConstructionSpec + CoreTests + CrossCarrierLaws + DeltaLaws + EpochSupport.Expected + EpochSupport.Generators + EpochSupport.Mapping + EpochSupport.Reference + EpochSupport.Types + EpochTests + FiniteSpec + LawManifest + LawsSpec + PatchReference + PatchLaws + PatchSupport + PatchTests + ProjectionSpec + ReferenceSpec + RepairTests + ReplaySpec + SemanticsSpec + DeltaHashSpec + TransportSpec + VersionSpec + ViewSpec + build-depends: + containers >= 0.8 && < 0.9 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-delta:moonlight-delta-core + , moonlight-delta:moonlight-delta-epoch + , moonlight-delta:moonlight-delta-patch-internal + , moonlight-delta:moonlight-delta-patch + , moonlight-delta:moonlight-delta-repair + , tasty-hunit >= 0.10 + , tasty-quickcheck >= 0.10 + , QuickCheck >= 2.14 + +common moonlight-delta-benchmark-properties + default-language: GHC2024 + ghc-options: -Wall -Wcompat -O2 -rtsopts + default-extensions: + TypeFamilies + build-depends: + base >= 4.22 && < 5 + , tasty-bench >= 0.3 && < 0.6 + +benchmark moonlight-delta-core-bench + import: moonlight-delta-benchmark-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/core + bench/support + main-is: Main.hs + other-modules: + BenchSupport + CoreBench + build-depends: + containers >= 0.8 && < 0.9 + , deepseq >= 1.4 + , moonlight-delta:moonlight-delta-core + +benchmark moonlight-delta-patch-bench + import: moonlight-delta-benchmark-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/patch + bench/support + test-support + main-is: Main.hs + other-modules: + BenchSupport + Patch.Allocation + Patch.Fixtures + Patch.Hackage + Patch.Types + PatchBench + PatchReference + build-depends: + containers >= 0.8 && < 0.9 + , deepseq >= 1.4 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-delta:moonlight-delta-core + , moonlight-delta:moonlight-delta-patch + +benchmark moonlight-delta-epoch-bench + import: moonlight-delta-benchmark-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/epoch + bench/support + main-is: Main.hs + other-modules: + BenchSupport + EpochBench + build-depends: + containers >= 0.8 && < 0.9 + , deepseq >= 1.4 + , moonlight-delta:moonlight-delta-epoch + +benchmark moonlight-delta-repair-bench + import: moonlight-delta-benchmark-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/repair + bench/support + main-is: Main.hs + other-modules: + BenchSupport + RepairBench + build-depends: + containers >= 0.8 && < 0.9 + , deepseq >= 1.4 + , moonlight-delta:moonlight-delta-repair + +benchmark moonlight-delta-bench + import: moonlight-delta-benchmark-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/aggregate + bench/core + bench/patch + bench/epoch + bench/repair + bench/support + test-support + main-is: Main.hs + other-modules: + BenchSupport + CoreBench + EpochBench + Patch.Allocation + Patch.Fixtures + Patch.Hackage + Patch.Types + PatchBench + PatchReference + RepairBench + build-depends: + containers >= 0.8 && < 0.9 + , deepseq >= 1.4 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-delta:moonlight-delta-core + , moonlight-delta:moonlight-delta-epoch + , moonlight-delta:moonlight-delta-patch + , moonlight-delta:moonlight-delta-repair diff --git a/src-core/Moonlight/Delta/Frontier.hs b/src-core/Moonlight/Delta/Frontier.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Delta/Frontier.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE DerivingStrategies #-} + +-- | Antichain frontiers over partial orders (lower, upper, and two-dimensional product variants), answering containment queries. +module Moonlight.Delta.Frontier + ( Frontier, + UpperFrontier, + ProductFrontier2, + emptyFrontier, + emptyUpperFrontier, + singletonFrontier, + singletonUpperFrontier, + mkFrontier, + mkUpperFrontier, + mkProductFrontier2, + frontierPoints, + upperFrontierPoints, + productFrontier2Points, + frontierNull, + upperFrontierNull, + frontierContains, + productFrontier2Contains, + insertPoint, + insertUpperFrontierPoint, + ) +where + +import Data.Bool (Bool (False, True)) +import Data.Foldable qualified as Foldable +import Data.Kind (Type) +import Data.List qualified as List +import Data.Map.Strict + ( Map, + ) +import Data.Map.Strict qualified as Map +import Moonlight.Core + ( PartialOrder (..), + ) +import Prelude (Eq (..), Maybe (..), Ord (..), Show, flip, maybe, min, not, otherwise, reverse, (.)) + +type LowerFrontierPolarity :: Type +data LowerFrontierPolarity + +type UpperFrontierPolarity :: Type +data UpperFrontierPolarity + +type FrontierWith :: Type -> Type -> Type +newtype FrontierWith polarity time = Frontier + { antichain :: [time] + } + deriving stock (Eq, Ord, Show) + +type Frontier :: Type -> Type +type Frontier = + FrontierWith LowerFrontierPolarity + +type UpperFrontier :: Type -> Type +type UpperFrontier = + FrontierWith UpperFrontierPolarity + +type ProductFrontier2 :: Type -> Type -> Type +newtype ProductFrontier2 left right = ProductFrontier2 + { staircase :: Map left right + } + deriving stock (Eq, Ord, Show) + +emptyFrontier :: Frontier time +emptyFrontier = + Frontier [] + +emptyUpperFrontier :: UpperFrontier time +emptyUpperFrontier = + Frontier [] + +singletonFrontier :: time -> Frontier time +singletonFrontier time = + Frontier [time] + +singletonUpperFrontier :: time -> UpperFrontier time +singletonUpperFrontier time = + Frontier [time] + +mkFrontier :: + (Ord time, PartialOrder time) => + [time] -> + Frontier time +mkFrontier times = + canonicalizeFrontier + (Foldable.foldl' (flip (insertFrontierRaw leq)) emptyFrontier times) + +mkUpperFrontier :: + (Ord time, PartialOrder time) => + [time] -> + UpperFrontier time +mkUpperFrontier times = + canonicalizeFrontier + (Foldable.foldl' (flip (insertFrontierRaw (flip leq))) emptyUpperFrontier times) + +mkProductFrontier2 :: + (Ord left, Ord right) => + [(left, right)] -> + ProductFrontier2 left right +mkProductFrontier2 = + ProductFrontier2 . productFrontierStaircase . Map.fromListWith min + +frontierPoints :: Frontier time -> [time] +frontierPoints = + antichain + +upperFrontierPoints :: UpperFrontier time -> [time] +upperFrontierPoints = + antichain + +productFrontier2Points :: ProductFrontier2 left right -> [(left, right)] +productFrontier2Points = + Map.toAscList . staircase + +frontierNull :: Frontier time -> Bool +frontierNull (Frontier times) = + case times of + [] -> True + _ -> False + +upperFrontierNull :: UpperFrontier time -> Bool +upperFrontierNull (Frontier times) = + case times of + [] -> True + _ -> False + +frontierContains :: + PartialOrder time => + time -> + Frontier time -> + Bool +frontierContains time (Frontier times) = + Foldable.any + (`leq` time) + times + +productFrontier2Contains :: + (Ord left, Ord right) => + (left, right) -> + ProductFrontier2 left right -> + Bool +productFrontier2Contains (left, right) (ProductFrontier2 staircase) = + maybe + False + (\(_, frontierRight) -> frontierRight <= right) + (Map.lookupLE left staircase) + +insertPoint :: + (Ord time, PartialOrder time) => + time -> + Frontier time -> + Frontier time +insertPoint = + insertFrontierWith leq + +insertUpperFrontierPoint :: + (Ord time, PartialOrder time) => + time -> + UpperFrontier time -> + UpperFrontier time +insertUpperFrontierPoint = + insertFrontierWith (flip leq) + +insertFrontierWith :: + Ord time => + (time -> time -> Bool) -> + time -> + FrontierWith polarity time -> + FrontierWith polarity time +insertFrontierWith coveredBy time frontier@(Frontier times) = + case times of + [] -> + Frontier [time] + [existingTime] + | existingTime `coveredBy` time -> + frontier + | time `coveredBy` existingTime -> + Frontier [time] + | otherwise -> + Frontier (List.insert time [existingTime]) + _ -> + if Foldable.any (`coveredBy` time) times + then frontier + else + Frontier (List.insert time (List.filter (not . coveredBy time) times)) + +insertFrontierRaw :: + (time -> time -> Bool) -> + time -> + FrontierWith polarity time -> + FrontierWith polarity time +insertFrontierRaw coveredBy time frontier@(Frontier times) = + case times of + [] -> + Frontier [time] + _ -> + if Foldable.any (`coveredBy` time) times + then frontier + else Frontier (time : List.filter (not . coveredBy time) times) + +canonicalizeFrontier :: Ord time => FrontierWith polarity time -> FrontierWith polarity time +canonicalizeFrontier (Frontier times) = + Frontier (List.sort times) + +productFrontierStaircase :: + Ord right => + Map left right -> + Map left right +productFrontierStaircase candidates = + Map.fromDistinctAscList (reverse keptEntries) + where + (_, keptEntries) = + Map.foldlWithKey' retainUndominated (Nothing, []) candidates + + retainUndominated :: + Ord right => + (Maybe right, [(left, right)]) -> + left -> + right -> + (Maybe right, [(left, right)]) + retainUndominated (bestRight, kept) left right = + case bestRight of + Nothing -> + (Just right, (left, right) : kept) + Just currentRight + | right < currentRight -> + (Just right, (left, right) : kept) + _ -> + (bestRight, kept) diff --git a/src-core/Moonlight/Delta/Monotone.hs b/src-core/Moonlight/Delta/Monotone.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Delta/Monotone.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DerivingStrategies #-} + +-- | Monotone deltas are relative increments plus an explicit rebase form. +-- +-- The application and composition laws hold exactly when the supplied join +-- function is associative. Join-over-Reset composes to +-- @ResetDelta (join target increment)@, which agrees with sequential +-- application on the nose; Join-over-Join is where associativity is required. +-- +-- 'ResetDelta' is the deliberate non-monotone rebase primitive. Composition +-- treats a newer 'ResetDelta' as left-absorbing, so rebasing discards all older +-- increments by construction. +module Moonlight.Delta.Monotone + ( Monotone (..), + applyDelta, + composeDelta, + mapDelta, + ) +where + +import Data.Kind (Type) +import Prelude (Eq, Ord, Show) + +type Monotone :: Type -> Type +data Monotone value + = JoinDelta !value + | ResetDelta !value + deriving stock (Eq, Ord, Show) + +applyDelta :: + (value -> value -> value) -> + Monotone value -> + value -> + value +applyDelta joinValue delta current = + case delta of + JoinDelta increment -> + joinValue current increment + ResetDelta target -> + target + +-- | Compose a newer monotone delta over an older monotone delta. +-- +-- Precondition: the supplied join function must be associative for +-- 'applyDelta' over 'composeDelta' to agree with sequential +-- application for every pair of deltas. A newer 'ResetDelta' is left-absorbing: +-- @composeDelta joinValue (ResetDelta target) older = ResetDelta target@. +-- An older 'ResetDelta' followed by @JoinDelta increment@ composes to +-- @ResetDelta (joinValue target increment)@. +composeDelta :: + (value -> value -> value) -> + Monotone value -> + Monotone value -> + Monotone value +composeDelta joinValue newer older = + case newer of + ResetDelta target -> + ResetDelta target + JoinDelta increment -> + case older of + ResetDelta target -> + ResetDelta (joinValue target increment) + JoinDelta priorIncrement -> + JoinDelta (joinValue priorIncrement increment) + +mapDelta :: + (left -> right) -> + Monotone left -> + Monotone right +mapDelta f delta = + case delta of + JoinDelta value -> + JoinDelta (f value) + ResetDelta value -> + ResetDelta (f value) diff --git a/src-core/Moonlight/Delta/Normalize.hs b/src-core/Moonlight/Delta/Normalize.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Delta/Normalize.hs @@ -0,0 +1,20 @@ +module Moonlight.Delta.Normalize + ( DeltaNormalize (..), + ) +where + +import Data.Bool (Bool) + +-- | Delta canonicalization. +-- +-- Instances must satisfy: +-- +-- * @normalizeDelta (normalizeDelta delta) == normalizeDelta delta@. +-- * @deltaNull (normalizeDelta delta) == deltaNull delta@. +-- +-- A null delta may still carry representation-specific data before +-- normalization, but canonical nulls should be stable under +-- 'normalizeDelta'. +class DeltaNormalize delta where + normalizeDelta :: delta -> delta + deltaNull :: delta -> Bool diff --git a/src-core/Moonlight/Delta/Operator.hs b/src-core/Moonlight/Delta/Operator.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Delta/Operator.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Stateful operators over 'Timed' streams: each step fails typed or yields the next state plus emissions; 'opFlush' ends the stream. +module Moonlight.Delta.Operator + ( OpResult (..), + Operator (..), + noOutput, + emitOnly, + retimeOpResult, + ) +where + +import Moonlight.Delta.Time + ( Timed (..), + retime, + ) +import Prelude (Either, Eq, Functor, Show, fmap) + +data OpResult time st out = OpResult + { orState :: !st, + orEmit :: ![Timed time out] + } + deriving stock (Eq, Show, Functor) + +data Operator time st input output err = Operator + { opStep :: st -> Timed time input -> Either err (OpResult time st output), + opFlush :: st -> Either err (OpResult time st output) + } + +noOutput :: st -> OpResult time st out +noOutput stateValue = + OpResult + { orState = stateValue, + orEmit = [] + } + +emitOnly :: st -> [Timed time out] -> OpResult time st out +emitOnly stateValue emitted = + OpResult + { orState = stateValue, + orEmit = emitted + } + +retimeOpResult :: + time -> + OpResult time st out -> + OpResult time st out +retimeOpResult eventTime result = + result {orEmit = fmap (retime eventTime) (orEmit result)} diff --git a/src-core/Moonlight/Delta/Scope.hs b/src-core/Moonlight/Delta/Scope.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Delta/Scope.hs @@ -0,0 +1,349 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Dirty-scope tracking with one type-indexed notion of emptiness. +module Moonlight.Delta.Scope + ( ScopeCarrier (..), + Scope, + Scoped (..), + cleanScope, + fullScope, + dirtyScope, + foldScope, + cleanDelta, + fullDelta, + payloadDelta, + scopedDelta, + normalizeScope, + normalizeScoped, + scopeNull, + scopedDeltaNull, + scopedDeltaHasPayload, + scopedDeltaSupport, + scopedDeltaPayload, + scopeKeys, + unionScope, + restrictScope, + mapScope, + mapScopedScope, + ) +where + +import Data.Kind (Type) +import Data.Maybe (Maybe (..), isJust) +import Moonlight.Delta.Normalize + ( DeltaNormalize (..), + ) +import Moonlight.Delta.Support + ( DeltaSupport (..), + ) +import Moonlight.Core + ( OrdSet (..), + ) +import Prelude + ( Bool (..), + Eq (..), + Monoid (..), + Ord (..), + Semigroup (..), + Show, + id, + not, + otherwise, + (&&), + (.), + ) + +type Scope :: Type -> Type +data Scope scope + = CleanScope + | DirtyScope !scope + | FullScope + deriving stock (Eq, Ord, Show) + +type Scoped :: Type -> Type -> Type +data Scoped scope payload = Scoped + { scope :: !(Scope scope), + payload :: !(Maybe payload) + } + deriving stock (Eq, Ord, Show) + +class ScopeCarrier scope where + scopeCarrierNull :: scope -> Bool + +instance {-# OVERLAPPABLE #-} OrdSet scope => ScopeCarrier scope where + scopeCarrierNull = + nullSet + +instance (ScopeCarrier scope, Semigroup scope) => Semigroup (Scope scope) where + (<>) = + unionScope + {-# INLINE (<>) #-} + +instance (ScopeCarrier scope, Semigroup scope) => Monoid (Scope scope) where + mempty = + CleanScope + {-# INLINE mempty #-} + +instance (ScopeCarrier scope, Semigroup scope, Semigroup payload) => Semigroup (Scoped scope payload) where + leftDelta <> rightDelta = + normalizeScoped + Scoped + { scope = + unionScope + (scope leftDelta) + (scope rightDelta), + payload = + payload leftDelta <> payload rightDelta + } + {-# INLINE (<>) #-} + +instance (ScopeCarrier scope, Semigroup scope, Semigroup payload) => Monoid (Scoped scope payload) where + mempty = + cleanDelta + {-# INLINE mempty #-} + +instance DeltaNormalize (Scope scope) where + normalizeDelta = + normalizeScope + {-# INLINE normalizeDelta #-} + + deltaNull = + scopeNull + {-# INLINE deltaNull #-} + +instance DeltaSupport (Scope scope) where + type DeltaSupportSet (Scope scope) = Scope scope + + emptySupport = + CleanScope + {-# INLINE emptySupport #-} + + deltaSupport = + normalizeScope + {-# INLINE deltaSupport #-} + +instance DeltaNormalize (Scoped scope payload) where + normalizeDelta = + normalizeScoped + {-# INLINE normalizeDelta #-} + + deltaNull = + scopedDeltaNull + {-# INLINE deltaNull #-} + +instance DeltaSupport (Scoped scope payload) where + type DeltaSupportSet (Scoped scope payload) = Scope scope + + emptySupport = + CleanScope + {-# INLINE emptySupport #-} + + deltaSupport = + scopedDeltaSupport + {-# INLINE deltaSupport #-} + +cleanScope :: Scope scope +cleanScope = + CleanScope +{-# INLINE cleanScope #-} + +fullScope :: Scope scope +fullScope = + FullScope +{-# INLINE fullScope #-} + +dirtyScope :: + ScopeCarrier scope => + scope -> + Scope scope +dirtyScope keys + | scopeCarrierNull keys = + CleanScope + | otherwise = + DirtyScope keys +{-# INLINE dirtyScope #-} + +cleanDelta :: Scoped scope payload +cleanDelta = + Scoped + { scope = cleanScope, + payload = Nothing + } +{-# INLINE cleanDelta #-} + +fullDelta :: Scoped scope payload +fullDelta = + Scoped + { scope = fullScope, + payload = Nothing + } +{-# INLINE fullDelta #-} + +payloadDelta :: payload -> Scoped scope payload +payloadDelta payload = + Scoped + { scope = cleanScope, + payload = Just payload + } +{-# INLINE payloadDelta #-} + +scopedDelta :: + Scope scope -> + Maybe payload -> + Scoped scope payload +scopedDelta scopeValue payloadValue = + normalizeScoped + Scoped + { scope = scopeValue, + payload = payloadValue + } +{-# INLINE scopedDelta #-} + +normalizeScope :: + Scope scope -> + Scope scope +normalizeScope = + id +{-# INLINE normalizeScope #-} + +foldScope :: + result -> + (scope -> result) -> + result -> + Scope scope -> + result +foldScope cleanCase dirtyCase fullCase scopeValue = + case scopeValue of + CleanScope -> + cleanCase + DirtyScope keys -> + dirtyCase keys + FullScope -> + fullCase +{-# INLINE foldScope #-} + +normalizeScoped :: + Scoped scope payload -> + Scoped scope payload +normalizeScoped = + id +{-# INLINE normalizeScoped #-} + +scopeNull :: + Scope scope -> + Bool +scopeNull scopeValue = + case scopeValue of + CleanScope -> + True + DirtyScope _ -> + False + FullScope -> + False +{-# INLINE scopeNull #-} + +scopedDeltaHasPayload :: Scoped scope payload -> Bool +scopedDeltaHasPayload = + isJust . payload +{-# INLINE scopedDeltaHasPayload #-} + +scopedDeltaNull :: + Scoped scope payload -> + Bool +scopedDeltaNull delta = + scopeNull (scope delta) + && not (scopedDeltaHasPayload delta) +{-# INLINE scopedDeltaNull #-} + +scopedDeltaSupport :: + Scoped scope payload -> + Scope scope +scopedDeltaSupport = + scope +{-# INLINE scopedDeltaSupport #-} + +scopedDeltaPayload :: Scoped scope payload -> Maybe payload +scopedDeltaPayload = + payload +{-# INLINE scopedDeltaPayload #-} + +scopeKeys :: + OrdSet scope => + Scope scope -> + Maybe scope +scopeKeys scopeValue = + case scopeValue of + CleanScope -> + Just emptySet + DirtyScope keys -> + Just keys + FullScope -> + Nothing +{-# INLINE scopeKeys #-} + +unionScope :: + (ScopeCarrier scope, Semigroup scope) => + Scope scope -> + Scope scope -> + Scope scope +unionScope leftScope rightScope = + case (leftScope, rightScope) of + (FullScope, _) -> + FullScope + (_, FullScope) -> + FullScope + (CleanScope, scopeValue) -> + scopeValue + (scopeValue, CleanScope) -> + scopeValue + (DirtyScope leftKeys, DirtyScope rightKeys) -> + dirtyScope (leftKeys <> rightKeys) +{-# INLINE unionScope #-} + +restrictScope :: + OrdSet scope => + scope -> + Scope scope -> + Scope scope +restrictScope restriction scopeValue = + if nullSet restriction + then cleanScope + else + case scopeValue of + CleanScope -> + cleanScope + DirtyScope keys -> + dirtyScope (intersectionSet restriction keys) + FullScope -> + dirtyScope restriction +{-# INLINE restrictScope #-} + +mapScope :: + ScopeCarrier targetScope => + (sourceScope -> targetScope) -> + Scope sourceScope -> + Scope targetScope +mapScope project scopeValue = + case scopeValue of + CleanScope -> + cleanScope + DirtyScope keys -> + dirtyScope (project keys) + FullScope -> + fullScope +{-# INLINE mapScope #-} + +mapScopedScope :: + ScopeCarrier targetScope => + (sourceScope -> targetScope) -> + Scoped sourceScope payload -> + Scoped targetScope payload +mapScopedScope project delta = + Scoped + { scope = mapScope project (scope delta), + payload = payload delta + } +{-# INLINE mapScopedScope #-} diff --git a/src-core/Moonlight/Delta/Signed.hs b/src-core/Moonlight/Delta/Signed.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Delta/Signed.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Integer-signed multiplicities and their changes: states stay non-negative, deltas carry sign, application is checked ('SignedApplyError'). +module Moonlight.Delta.Signed + ( Multiplicity (..), + MultiplicityChange (..), + multiplicityValue, + multiplicityChangeValue, + zeroMultiplicity, + zeroMultiplicityChange, + addMultiplicity, + subtractMultiplicity, + addMultiplicityChange, + negateMultiplicityChange, + multiplicityAsChange, + positiveMultiplicityChange, + applyMultiplicityChange, + SignedApplyError (..), + Signed, + emptySigned, + singletonSigned, + signedFromList, + signedFromChangeMap, + signedToAscList, + signedToChangeMap, + mapSignedKeys, + traverseSignedKeysWith, + signedNull, + support, + combineSigned, + negateSigned, + applySignedToMap, + ) +where + +import Data.Bool (Bool, otherwise) +import Data.Eq (Eq, (==), (/=)) +import Data.Kind (Type) +import Data.List qualified as List +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (Maybe (Just, Nothing)) +import Data.Ord (Ord, Ordering (..), compare, (<), (>), (>=)) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Moonlight.Delta.Normalize + ( DeltaNormalize (..), + ) +import Moonlight.Delta.Support + ( DeltaSupport (..), + ) +import Prelude + ( Either (Left, Right), + Int, + Integer, + Num (..), + Show, + fmap, + foldr, + fromIntegral, + fst, + toInteger, + traverse, + ($), + (.), + ) +import Numeric.Natural (Natural) + +type Multiplicity :: Type +newtype Multiplicity = Multiplicity + { unMultiplicity :: Natural + } + deriving stock (Eq, Ord, Show) + +type MultiplicityChange :: Type +newtype MultiplicityChange = MultiplicityChange + { unMultiplicityChange :: Integer + } + deriving stock (Eq, Ord, Show) + +type SignedApplyError :: Type -> Type +data SignedApplyError key = SignedMultiplicityUnderflow + { saeKey :: !key, + saeOldMultiplicity :: !Multiplicity, + saeDeltaMultiplicity :: !MultiplicityChange + } + deriving stock (Eq, Ord, Show) + +type Signed :: Type -> Type +-- | Canonical ascending changes. The constructor is private; every public +-- introduction path consolidates equal keys and removes zero changes. +newtype Signed key = Signed + { entries :: Vector (key, MultiplicityChange) + } + deriving stock (Eq, Ord, Show) + +emptySigned :: Signed key +emptySigned = + Signed Vector.empty + +singletonSigned :: + key -> + Int -> + Signed key +singletonSigned key diff = + if diff == 0 + then emptySigned + else Signed (Vector.singleton (key, MultiplicityChange (fromIntegral diff))) + +signedFromList :: + Ord key => + [(key, Int)] -> + Signed key +signedFromList = + Signed . consolidateChangeEntries . fmap (\(key, value) -> (key, MultiplicityChange (fromIntegral value))) + +signedFromChangeMap :: + Map key MultiplicityChange -> + Signed key +signedFromChangeMap = + Signed . Vector.fromList . Map.toAscList . Map.filter nonZeroChange + +signedToAscList :: + Signed key -> + [(key, MultiplicityChange)] +signedToAscList (Signed entries) = + Vector.toList entries + +signedToChangeMap :: + Signed key -> + Map key MultiplicityChange +signedToChangeMap = + Map.fromDistinctAscList . signedToAscList + +mapSignedKeys :: + Ord target => + (source -> target) -> + Signed source -> + Signed target +mapSignedKeys project (Signed entries) = + Signed (consolidateChangeEntries (fmap (\(key, multiplicity) -> (project key, multiplicity)) (Vector.toList entries))) + +traverseSignedKeysWith :: + Ord target => + (source -> Either err target) -> + Signed source -> + Either err (Signed target) +traverseSignedKeysWith project (Signed entries) = + fmap (Signed . consolidateChangeEntries) $ + traverse + (\(key, multiplicity) -> fmap (\target -> (target, multiplicity)) (project key)) + (Vector.toList entries) + +signedNull :: + Signed key -> + Bool +signedNull = + Vector.null . entries + +support :: Signed key -> Set key +support = + Set.fromDistinctAscList . fmap fst . signedToAscList + +combineSigned :: + Ord key => + Signed key -> + Signed key -> + Signed key +combineSigned (Signed newer) (Signed older) = + Signed (Vector.unfoldr mergeStep (0, 0)) + where + mergeStep (newerIndex, olderIndex) = + case (newer Vector.!? newerIndex, older Vector.!? olderIndex) of + (Nothing, Nothing) -> + Nothing + (Just newerEntry, Nothing) -> + Just (newerEntry, (newerIndex + 1, olderIndex)) + (Nothing, Just olderEntry) -> + Just (olderEntry, (newerIndex, olderIndex + 1)) + (Just newerEntry@(newerKey, newerMultiplicity), Just olderEntry@(olderKey, olderMultiplicity)) -> + case compare newerKey olderKey of + LT -> + Just (newerEntry, (newerIndex + 1, olderIndex)) + GT -> + Just (olderEntry, (newerIndex, olderIndex + 1)) + EQ -> + let combined = + addMultiplicityChange newerMultiplicity olderMultiplicity + in if nonZeroChange combined + then Just ((newerKey, combined), (newerIndex + 1, olderIndex + 1)) + else mergeStep (newerIndex + 1, olderIndex + 1) + +negateSigned :: + Signed key -> + Signed key +negateSigned (Signed rows) = + Signed (Vector.map (\(key, multiplicity) -> (key, negateMultiplicityChange multiplicity)) rows) + +applySignedToMap :: + forall key. + Ord key => + Signed key -> + Map key Multiplicity -> + Either (SignedApplyError key) (Map key Multiplicity) +applySignedToMap (Signed deltaRows) state0 = + Vector.foldM applyOne state0 deltaRows + where + applyOne :: + Map key Multiplicity -> + (key, MultiplicityChange) -> + Either (SignedApplyError key) (Map key Multiplicity) + applyOne state (key, diff) = + let old = + Map.findWithDefault zeroMultiplicity key state + in case applyMultiplicityChange old diff of + Nothing -> + Left + SignedMultiplicityUnderflow + { saeKey = key, + saeOldMultiplicity = old, + saeDeltaMultiplicity = diff + } + Just newMultiplicity -> + Right (writeMultiplicity key newMultiplicity state) + +zeroMultiplicity :: Multiplicity +zeroMultiplicity = + Multiplicity 0 + +multiplicityValue :: Multiplicity -> Natural +multiplicityValue = + unMultiplicity + +multiplicityChangeValue :: MultiplicityChange -> Integer +multiplicityChangeValue = + unMultiplicityChange + +zeroMultiplicityChange :: MultiplicityChange +zeroMultiplicityChange = + MultiplicityChange 0 + +nonZeroChange :: MultiplicityChange -> Bool +nonZeroChange (MultiplicityChange value) = + value /= 0 + +addMultiplicity :: Multiplicity -> Multiplicity -> Multiplicity +addMultiplicity (Multiplicity left) (Multiplicity right) = + Multiplicity (left + right) + +subtractMultiplicity :: Multiplicity -> Multiplicity -> Maybe Multiplicity +subtractMultiplicity (Multiplicity left) (Multiplicity right) + | left >= right = + Just (Multiplicity (left - right)) + | otherwise = + Nothing + +addMultiplicityChange :: MultiplicityChange -> MultiplicityChange -> MultiplicityChange +addMultiplicityChange (MultiplicityChange left) (MultiplicityChange right) = + MultiplicityChange (left + right) + +negateMultiplicityChange :: MultiplicityChange -> MultiplicityChange +negateMultiplicityChange (MultiplicityChange value) = + MultiplicityChange (negate value) + +multiplicityAsChange :: Multiplicity -> MultiplicityChange +multiplicityAsChange (Multiplicity value) = + MultiplicityChange (toInteger value) + +positiveMultiplicityChange :: MultiplicityChange -> Maybe Multiplicity +positiveMultiplicityChange (MultiplicityChange value) + | value > 0 = + Just (Multiplicity (fromInteger value)) + | otherwise = + Nothing + +applyMultiplicityChange :: Multiplicity -> MultiplicityChange -> Maybe Multiplicity +applyMultiplicityChange (Multiplicity oldValue) (MultiplicityChange changeValue) = + let newValue = + toInteger oldValue + changeValue + in if newValue < 0 + then Nothing + else Just (Multiplicity (fromInteger newValue)) + +writeMultiplicity :: + Ord key => + key -> + Multiplicity -> + Map key Multiplicity -> + Map key Multiplicity +writeMultiplicity key multiplicity@(Multiplicity value) state = + if value == 0 + then Map.delete key state + else Map.insert key multiplicity state + +consolidateChangeEntries :: + forall key. + Ord key => + [(key, MultiplicityChange)] -> + Vector (key, MultiplicityChange) +consolidateChangeEntries entries = + Vector.fromList + ( case consolidateAscendingEntries entries of + Just consolidatedEntries -> + consolidatedEntries + Nothing -> + consolidateSortedEntries (List.sortBy compareEntryKeys entries) + ) + where + compareEntryKeys :: + (key, MultiplicityChange) -> + (key, MultiplicityChange) -> + Ordering + compareEntryKeys (leftKey, _) (rightKey, _) = + compare leftKey rightKey + + consolidateAscendingEntries :: + [(key, MultiplicityChange)] -> + Maybe [(key, MultiplicityChange)] + consolidateAscendingEntries = + fmap List.reverse . List.foldl' insertAscendingEntry (Just []) + + insertAscendingEntry :: + Maybe [(key, MultiplicityChange)] -> + (key, MultiplicityChange) -> + Maybe [(key, MultiplicityChange)] + insertAscendingEntry maybeEntries entry@(key, multiplicity) = + case maybeEntries of + Nothing -> + Nothing + Just entriesSoFar -> + case entriesSoFar of + [] -> + Just (if nonZeroChange multiplicity then [entry] else []) + (previousKey, previousMultiplicity) : rest -> + case compare previousKey key of + GT -> + Nothing + EQ -> + let combined = + addMultiplicityChange previousMultiplicity multiplicity + in Just (if nonZeroChange combined then (key, combined) : rest else rest) + LT -> + Just (if nonZeroChange multiplicity then entry : entriesSoFar else entriesSoFar) + + consolidateSortedEntries :: + [(key, MultiplicityChange)] -> + [(key, MultiplicityChange)] + consolidateSortedEntries = + foldr insertSortedEntry [] + + insertSortedEntry :: + (key, MultiplicityChange) -> + [(key, MultiplicityChange)] -> + [(key, MultiplicityChange)] + insertSortedEntry entry@(key, multiplicity) consolidatedEntries = + case consolidatedEntries of + (nextKey, nextMultiplicity) : rest + | key == nextKey -> + let combined = + addMultiplicityChange multiplicity nextMultiplicity + in if nonZeroChange combined + then (key, combined) : rest + else rest + _ -> + if nonZeroChange multiplicity + then entry : consolidatedEntries + else consolidatedEntries + +instance DeltaNormalize (Signed key) where + normalizeDelta signedValue = + signedValue + + deltaNull = + signedNull + +instance DeltaSupport (Signed key) where + type DeltaSupportSet (Signed key) = Set key + + emptySupport = + Set.empty + + deltaSupport = + support diff --git a/src-core/Moonlight/Delta/Support.hs b/src-core/Moonlight/Delta/Support.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Delta/Support.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} + +module Moonlight.Delta.Support + ( DeltaSupport (..), + ) +where + +import Data.Kind (Type) + +-- | Support projection for deltas. +-- +-- Instances must satisfy: +-- +-- * @deltaSupport (normalizeDelta delta) == deltaSupport delta@ when the +-- delta type also has a 'Moonlight.Delta.Normalize.DeltaNormalize' +-- instance. +-- * null deltas should report 'emptySupport'. +-- +-- The support set is the observable footprint of a delta, not an internal +-- storage summary. +class DeltaSupport delta where + type DeltaSupportSet delta :: Type + + emptySupport :: DeltaSupportSet delta + deltaSupport :: delta -> DeltaSupportSet delta diff --git a/src-core/Moonlight/Delta/Time.hs b/src-core/Moonlight/Delta/Time.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Delta/Time.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | A value stamped with its event time; 'retime' replaces the stamp and nothing else. +module Moonlight.Delta.Time + ( Timed (..), + retime, + ) +where + +import Data.Kind (Type) +import Prelude (Eq, Functor, Ord, Read, Show) + +type Timed :: Type -> Type -> Type +data Timed time value = Timed + { timedAt :: !time, + timedValue :: !value + } + deriving stock (Eq, Ord, Show, Read, Functor) + +retime :: time -> Timed time value -> Timed time value +retime eventTime timed = + timed {timedAt = eventTime} diff --git a/src-epoch/Moonlight/Delta/Epoch.hs b/src-epoch/Moonlight/Delta/Epoch.hs new file mode 100644 --- /dev/null +++ b/src-epoch/Moonlight/Delta/Epoch.hs @@ -0,0 +1,113 @@ +-- | The epoch calculus: version-anchored key transport between endpoint +-- snapshots. +-- +-- 'Version' is an opaque, unbounded epoch counter. An 'Endpoint' pairs a +-- version with the result-key universe observed at that instant. An +-- 'EpochDelta' is an abstract partial transport: source keys either descend to +-- target keys or retire, and the carrier owns its target-side dirty set. +-- +-- 'ContextProjectionDelta' is the bounded join-semilattice of dirty-key +-- pairs; its 'Data.Semigroup.Semigroup'/'Data.Monoid.Monoid' structure is +-- the seam consumed upstream and is preserved verbatim. +module Moonlight.Delta.Epoch + ( Version, + initialVersion, + nextVersion, + versionKey, + versionFromKey, + ContextProjectionDelta (..), + emptyContextProjectionDelta, + dirtyBaseDelta, + dirtyResultDelta, + normalizeContextProjectionDelta, + nullContextProjectionDelta, + mapContextProjectionDelta, + ContextView (..), + viewAt, + viewWithVersion, + viewWithSupport, + viewWithSection, + mapContextViewKeys, + contextViewIsCurrent, + contextViewIsStale, + EpochKeyed, + Endpoint (..), + EpochDelta, + epochDelta, + identityDelta, + DeltaViolation (..), + sourceEndpointOf, + targetEndpointOf, + sourceVersion, + targetVersion, + sourceKeys, + targetKeys, + transportOverrides, + freshKeys, + retiredKeys, + changedKeysAcrossEpoch, + transportKeys, + Transport (..), + ViewTransportError (..), + transportView, + ComposeError (..), + composeDelta, + ) +where + +import Moonlight.Delta.Epoch.Internal.Compose + ( composeDelta, + ) +import Moonlight.Delta.Epoch.Internal.Construction + ( epochDelta, + identityDelta, + ) +import Moonlight.Delta.Epoch.Internal.Projection + ( ContextProjectionDelta (..), + dirtyBaseDelta, + dirtyResultDelta, + emptyContextProjectionDelta, + mapContextProjectionDelta, + normalizeContextProjectionDelta, + nullContextProjectionDelta, + ) +import Moonlight.Delta.Epoch.Internal.Transport + ( transportKeys, + transportView, + ) +import Moonlight.Delta.Epoch.Internal.Types + ( ComposeError (..), + EpochDelta, + DeltaViolation (..), + Endpoint (..), + EpochKeyed, + Transport (..), + ViewTransportError (..), + changedKeysAcrossEpoch, + freshKeys, + retiredKeys, + sourceEndpointOf, + sourceKeys, + sourceVersion, + targetEndpointOf, + targetKeys, + targetVersion, + transportOverrides, + ) +import Moonlight.Delta.Epoch.Internal.Version + ( Version, + versionFromKey, + versionKey, + initialVersion, + nextVersion, + ) +import Moonlight.Delta.Epoch.Internal.View + ( ContextView (..), + contextViewIsCurrent, + contextViewIsStale, + mapContextViewKeys, + viewAt, + viewWithSection, + viewWithSupport, + viewWithVersion, + ) diff --git a/src-epoch/Moonlight/Delta/Epoch/Internal/Compose.hs b/src-epoch/Moonlight/Delta/Epoch/Internal/Compose.hs new file mode 100644 --- /dev/null +++ b/src-epoch/Moonlight/Delta/Epoch/Internal/Compose.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Total composition of boundary-compatible partial epoch transports. +module Moonlight.Delta.Epoch.Internal.Compose + ( composeDelta, + ) +where + +import Moonlight.Core (OrdMap (..), OrdSet (..)) +import Moonlight.Delta.Epoch.Internal.Types + ( ComposeError (..), + EpochDelta (..), + EpochKeyed, + sourceKeys, + sourceVersion, + targetKeys, + targetVersion, + transportKeyTotal, + ) +import Prelude + ( Either (..), + Eq, + Maybe (..), + otherwise, + (>>=), + (/=), + ) + +-- | Compose a newer delta over an older delta. +composeDelta :: + (EpochKeyed keyMap observed, Eq observed) => + EpochDelta keyMap observed -> + EpochDelta keyMap observed -> + Either (ComposeError (SetKey observed)) (EpochDelta keyMap observed) +composeDelta newer older + | targetVersion older /= sourceVersion newer = + Left (ComposeVersionMismatch (targetVersion older) (sourceVersion newer)) + | targetKeys older /= sourceKeys newer = + Left ComposeUniverseMismatch + | otherwise = + Right + EpochDelta + { sourceEndpoint = sourceEndpoint older, + targetEndpoint = targetEndpoint newer, + transportOverride = compositeOverrides, + retiredSourceKeys = compositeRetired, + dirtyTargetKeys = compositeDirty + } + where + sourceKeyList = toAscListSet (sourceKeys older) + + compositeTarget sourceKey = + transportKeyTotal older sourceKey + >>= transportKeyTotal newer + + compositeRetired = + fromListSet + [ sourceKey + | sourceKey <- sourceKeyList, + Nothing <- [compositeTarget sourceKey] + ] + + compositeOverrides = + fromListMap + [ (sourceKey, targetKey) + | sourceKey <- sourceKeyList, + Just targetKey <- [compositeTarget sourceKey], + sourceKey /= targetKey + ] + + transportedOlderDirty = + fromListSet + [ targetKey + | dirtyKey <- toAscListSet (dirtyTargetKeys older), + Just targetKey <- [transportKeyTotal newer dirtyKey] + ] + + compositeDirty = + unionSet transportedOlderDirty (dirtyTargetKeys newer) diff --git a/src-epoch/Moonlight/Delta/Epoch/Internal/Construction.hs b/src-epoch/Moonlight/Delta/Epoch/Internal/Construction.hs new file mode 100644 --- /dev/null +++ b/src-epoch/Moonlight/Delta/Epoch/Internal/Construction.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The sole construction boundary for nonidentity epoch deltas. +module Moonlight.Delta.Epoch.Internal.Construction + ( epochDelta, + identityDelta, + ) +where + +import Data.Maybe (fromMaybe) +import Moonlight.Core (OrdMap (..), OrdSet (..)) +import Moonlight.Delta.Epoch.Internal.Types + ( DeltaViolation (..), + Endpoint (..), + EpochDelta (..), + EpochKeyed, + survivingTransportImage, + ) +import Prelude + ( Either (..), + Ord ((>=)), + fmap, + fst, + not, + otherwise, + (/=), + ) + +epochDelta :: + EpochKeyed keyMap observed => + Endpoint observed -> + Endpoint observed -> + keyMap -> + observed -> + observed -> + Either (DeltaViolation (SetKey observed)) (EpochDelta keyMap observed) +epochDelta sourceEndpoint targetEndpoint transportProposal retiredProposal changedProposal + | sourceVersion >= targetVersion = + Left (VersionDidNotAdvance sourceVersion targetVersion) + | otherwise = + case domainEscapes of + badKey : _ -> + Left (TransportDomainEscapesSource badKey) + [] -> + case imageEscapes of + (badKey, badImage) : _ -> + Left (TransportImageEscapesTarget badKey badImage) + [] -> + case retiredEscapes of + badKey : _ -> + Left (RetiredKeyOutsideSource badKey) + [] -> + case transportsRetired of + badKey : _ -> + Left (TransportDefinedForRetiredSource badKey) + [] -> + case survivingEscapes of + badKey : _ -> + Left (SurvivingKeyOutsideTarget badKey) + [] -> + case changedEscapes of + badKey : _ -> + Left (ChangedKeyOutsideSource badKey) + [] -> + Right + EpochDelta + { sourceEndpoint = sourceEndpoint, + targetEndpoint = targetEndpoint, + transportOverride = strippedTransport, + retiredSourceKeys = retiredProposal, + dirtyTargetKeys = targetDirtyKeys + } + where + sourceVersion = endpointVersion sourceEndpoint + targetVersion = endpointVersion targetEndpoint + sourceKeySet = endpointKeys sourceEndpoint + targetKeySet = endpointKeys targetEndpoint + proposalEntries = toAscListMap transportProposal + strippedEntries = + [ (sourceKey, targetKey) + | (sourceKey, targetKey) <- proposalEntries, + sourceKey /= targetKey + ] + strippedTransport = fromListMap strippedEntries + domainEscapes = + [ sourceKey + | (sourceKey, _) <- proposalEntries, + not (memberSet sourceKey sourceKeySet) + ] + imageEscapes = + [ (sourceKey, targetKey) + | (sourceKey, targetKey) <- proposalEntries, + not (memberSet targetKey targetKeySet) + ] + retiredEscapes = + toAscListSet (differenceSet retiredProposal sourceKeySet) + transportsRetired = + [ sourceKey + | (sourceKey, _) <- proposalEntries, + memberSet sourceKey retiredProposal + ] + survivingEscapes = + toAscListSet (differenceSet identitySurvivingKeys targetKeySet) + identitySurvivingKeys = + differenceSet + (differenceSet sourceKeySet retiredProposal) + (fromListSet (fmap fst strippedEntries)) + targetFor sourceKey = + fromMaybe sourceKey (lookupMap sourceKey strippedTransport) + changedEscapes = + toAscListSet (differenceSet changedProposal sourceKeySet) + survivingImage = + survivingTransportImage sourceKeySet strippedTransport retiredProposal + freshTargetKeys = + differenceSet targetKeySet survivingImage + transportedChangedKeys = + fromListSet + [ targetFor sourceKey + | sourceKey <- toAscListSet changedProposal, + not (memberSet sourceKey retiredProposal) + ] + targetDirtyKeys = + unionSet transportedChangedKeys freshTargetKeys + +identityDelta :: + EpochKeyed keyMap observed => + Endpoint observed -> + EpochDelta keyMap observed +identityDelta endpoint = + EpochDelta + { sourceEndpoint = endpoint, + targetEndpoint = endpoint, + transportOverride = emptyMap, + retiredSourceKeys = emptySet, + dirtyTargetKeys = emptySet + } diff --git a/src-epoch/Moonlight/Delta/Epoch/Internal/Projection.hs b/src-epoch/Moonlight/Delta/Epoch/Internal/Projection.hs new file mode 100644 --- /dev/null +++ b/src-epoch/Moonlight/Delta/Epoch/Internal/Projection.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The context projection join-semilattice: a pair of dirty-key sets under +-- componentwise union — a commutative idempotent monoid whose components are +-- canonical persistent sets read independently by consumers. The carrier is +-- canonical by construction, so 'normalizeContextProjectionDelta' is the +-- identity: both components have no representational slack, they inhabit +-- different key spaces, and every eliminator reads one component alone, so +-- any non-identity normalization would alter observable content for some +-- input. The exported witnesses answer to the 'DeltaNormalize' and +-- 'DeltaSupport' contracts and are enrolled in the package law harnesses. +module Moonlight.Delta.Epoch.Internal.Projection + ( ContextProjectionDelta (..), + emptyContextProjectionDelta, + dirtyBaseDelta, + dirtyResultDelta, + normalizeContextProjectionDelta, + nullContextProjectionDelta, + mapContextProjectionDelta, + ) +where + +import Data.Kind (Type) +import Moonlight.Core (OrdSet (..)) +import Moonlight.Delta.Normalize (DeltaNormalize (..)) +import Moonlight.Delta.Support (DeltaSupport (..)) +import Prelude + ( Bool, + Eq, + Functor, + Monoid (..), + Ord, + Semigroup (..), + Show, + fmap, + id, + (&&), + (.), + ) + +type ContextProjectionDelta :: Type -> Type +data ContextProjectionDelta observed = ContextProjectionDelta + { dirtyBaseKeys :: !observed, + dirtyResultKeys :: !observed + } + deriving stock (Eq, Ord, Show, Functor) + +instance OrdSet observed => Semigroup (ContextProjectionDelta observed) where + leftDelta <> rightDelta = + ContextProjectionDelta + { dirtyBaseKeys = + unionSet (dirtyBaseKeys leftDelta) (dirtyBaseKeys rightDelta), + dirtyResultKeys = + unionSet (dirtyResultKeys leftDelta) (dirtyResultKeys rightDelta) + } + +instance OrdSet observed => Monoid (ContextProjectionDelta observed) where + mempty = emptyContextProjectionDelta + +emptyContextProjectionDelta :: OrdSet observed => ContextProjectionDelta observed +emptyContextProjectionDelta = + ContextProjectionDelta + emptySet + emptySet + +dirtyBaseDelta :: OrdSet observed => SetKey observed -> ContextProjectionDelta observed +dirtyBaseDelta key = + emptyContextProjectionDelta + { dirtyBaseKeys = singletonSet key + } + +dirtyResultDelta :: OrdSet observed => SetKey observed -> ContextProjectionDelta observed +dirtyResultDelta key = + emptyContextProjectionDelta + { dirtyResultKeys = singletonSet key + } + +normalizeContextProjectionDelta :: ContextProjectionDelta observed -> ContextProjectionDelta observed +normalizeContextProjectionDelta = + id +{-# INLINE normalizeContextProjectionDelta #-} + +nullContextProjectionDelta :: OrdSet observed => ContextProjectionDelta observed -> Bool +nullContextProjectionDelta deltaValue = + nullSet (dirtyBaseKeys deltaValue) + && nullSet (dirtyResultKeys deltaValue) +{-# INLINE nullContextProjectionDelta #-} + +instance OrdSet observed => DeltaNormalize (ContextProjectionDelta observed) where + normalizeDelta = + normalizeContextProjectionDelta + + deltaNull = + nullContextProjectionDelta + +instance OrdSet observed => DeltaSupport (ContextProjectionDelta observed) where + type DeltaSupportSet (ContextProjectionDelta observed) = ContextProjectionDelta observed + + emptySupport = + emptyContextProjectionDelta + + deltaSupport = + normalizeContextProjectionDelta + +mapContextProjectionDelta :: + (OrdSet observed1, OrdSet observed2) => + (SetKey observed1 -> SetKey observed2) -> + ContextProjectionDelta observed1 -> + ContextProjectionDelta observed2 +mapContextProjectionDelta rekey deltaValue = + ContextProjectionDelta + { dirtyBaseKeys = rekeySet rekey (dirtyBaseKeys deltaValue), + dirtyResultKeys = rekeySet rekey (dirtyResultKeys deltaValue) + } + +rekeySet :: + (OrdSet observed1, OrdSet observed2) => + (SetKey observed1 -> SetKey observed2) -> + observed1 -> + observed2 +rekeySet rekey = + fromListSet . fmap rekey . toAscListSet diff --git a/src-epoch/Moonlight/Delta/Epoch/Internal/Transport.hs b/src-epoch/Moonlight/Delta/Epoch/Internal/Transport.hs new file mode 100644 --- /dev/null +++ b/src-epoch/Moonlight/Delta/Epoch/Internal/Transport.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Query descent and view gluing for partial epoch transports. +module Moonlight.Delta.Epoch.Internal.Transport + ( transportKeys, + transportView, + ) +where + +import Moonlight.Core (OrdMap (..), OrdSet (..)) +import Moonlight.Delta.Epoch.Internal.Types + ( EpochDelta, + EpochKeyed, + Transport (..), + ViewTransportError (..), + retiredKeys, + sourceKeys, + sourceVersion, + targetVersion, + transportKeyTotal, + ) +import Moonlight.Delta.Epoch.Internal.View + ( ContextView (..), + viewWithSupport, + viewWithVersion, + ) +import Prelude (Either (..), Eq ((/=)), Maybe (..), fmap, otherwise, snd) + +transportKeys :: + EpochKeyed keyMap observed => + EpochDelta keyMap observed -> + observed -> + Transport keyMap observed +transportKeys deltaValue queryKeys = + Transport + { transportedKeys = + fromListMap + [ (sourceKey, targetKey) + | sourceKey <- toAscListSet survivingKeys, + Just targetKey <- [transportKeyTotal deltaValue sourceKey] + ], + transportRetiredKeys = queriedRetiredKeys, + transportUnknownKeys = unknownKeys + } + where + knownKeys = intersectionSet queryKeys (sourceKeys deltaValue) + unknownKeys = differenceSet queryKeys (sourceKeys deltaValue) + queriedRetiredKeys = intersectionSet knownKeys (retiredKeys deltaValue) + survivingKeys = differenceSet knownKeys queriedRetiredKeys +{-# INLINABLE transportKeys #-} + +transportView :: + EpochKeyed keyMap observed => + EpochDelta keyMap observed -> + ContextView observed section -> + Either (ViewTransportError (SetKey observed)) (ContextView observed section) +transportView deltaValue contextView + | cvVersion contextView /= sourceVersion deltaValue = + Left (ViewSourceVersionMismatch (sourceVersion deltaValue) (cvVersion contextView)) + | otherwise = + case toAscListSet (transportUnknownKeys transportResult) of + unknownKey : _ -> + Left (ViewObservedKeyUnknown unknownKey) + [] -> + Right + ( viewWithVersion + (targetVersion deltaValue) + ( viewWithSupport + (fromListSet (fmap snd (toAscListMap (transportedKeys transportResult)))) + contextView + ) + ) + where + transportResult = + transportKeys deltaValue (cvObservedKeys contextView) +{-# INLINABLE transportView #-} diff --git a/src-epoch/Moonlight/Delta/Epoch/Internal/Types.hs b/src-epoch/Moonlight/Delta/Epoch/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src-epoch/Moonlight/Delta/Epoch/Internal/Types.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Carriers of the epoch calculus. +-- +-- An 'Endpoint' is the complete object of the calculus: a version and the key +-- universe present at that version. An 'EpochDelta' stores a partial transport +-- from its source object to its target object. Source keys either survive via +-- the identity-almost-everywhere override or occur in the explicit retirement +-- set. Target dirtiness is stored directly because it is the compositional fact +-- consumed downstream. +module Moonlight.Delta.Epoch.Internal.Types + ( EpochKeyed, + Endpoint (..), + EpochDelta (..), + DeltaViolation (..), + ViewTransportError (..), + ComposeError (..), + Transport (..), + sourceEndpointOf, + targetEndpointOf, + sourceVersion, + targetVersion, + sourceKeys, + targetKeys, + transportOverrides, + retiredKeys, + freshKeys, + changedKeysAcrossEpoch, + transportKeyTotal, + survivingTransportImage, + ) +where + +import Data.Kind (Constraint, Type) +import Data.Maybe (fromMaybe) +import Data.Type.Equality (type (~)) +import Moonlight.Core (OrdMap (..), OrdSet (..)) +import Moonlight.Delta.Epoch.Internal.Version (Version) +import Moonlight.Delta.Normalize (DeltaNormalize (..)) +import Moonlight.Delta.Support (DeltaSupport (..)) +import Prelude + ( Bool (..), + Eq ((==)), + Maybe (..), + Show, + fmap, + fst, + id, + otherwise, + snd, + (&&), + ) + +type EpochKeyed :: Type -> Type -> Constraint +type EpochKeyed keyMap observed = + ( OrdMap keyMap, + OrdSet observed, + MapKey keyMap ~ SetKey observed, + MapValue keyMap ~ SetKey observed, + Eq (SetKey observed) + ) + +type Endpoint :: Type -> Type +data Endpoint observed = Endpoint + { endpointVersion :: !Version, + endpointKeys :: !observed + } + deriving stock (Eq, Show) + +type EpochDelta :: Type -> Type -> Type +data EpochDelta keyMap observed = EpochDelta + { sourceEndpoint :: !(Endpoint observed), + targetEndpoint :: !(Endpoint observed), + transportOverride :: !keyMap, + retiredSourceKeys :: !observed, + dirtyTargetKeys :: !observed + } + deriving stock (Eq, Show) + +type DeltaViolation :: Type -> Type +data DeltaViolation key + = VersionDidNotAdvance !Version !Version + | TransportDomainEscapesSource !key + | TransportImageEscapesTarget !key !key + | TransportDefinedForRetiredSource !key + | RetiredKeyOutsideSource !key + | SurvivingKeyOutsideTarget !key + | ChangedKeyOutsideSource !key + deriving stock (Eq, Show) + +type ViewTransportError :: Type -> Type +data ViewTransportError key + = ViewSourceVersionMismatch !Version !Version + | ViewObservedKeyUnknown !key + deriving stock (Eq, Show) + +type ComposeError :: Type -> Type +data ComposeError key + = ComposeVersionMismatch !Version !Version + | ComposeUniverseMismatch + deriving stock (Eq, Show) + +-- | The descent result for an arbitrary query. The domain of +-- 'transportedKeys', 'transportRetiredKeys', and 'transportUnknownKeys' +-- partitions the queried source keys. Map values are always target keys. +type Transport :: Type -> Type -> Type +data Transport keyMap observed = Transport + { transportedKeys :: !keyMap, + transportRetiredKeys :: !observed, + transportUnknownKeys :: !observed + } + deriving stock (Eq, Show) + +sourceEndpointOf :: EpochDelta keyMap observed -> Endpoint observed +sourceEndpointOf = + sourceEndpoint +{-# INLINE sourceEndpointOf #-} + +targetEndpointOf :: EpochDelta keyMap observed -> Endpoint observed +targetEndpointOf = + targetEndpoint +{-# INLINE targetEndpointOf #-} + +sourceVersion :: EpochDelta keyMap observed -> Version +sourceVersion deltaValue = + endpointVersion (sourceEndpoint deltaValue) +{-# INLINE sourceVersion #-} + +targetVersion :: EpochDelta keyMap observed -> Version +targetVersion deltaValue = + endpointVersion (targetEndpoint deltaValue) +{-# INLINE targetVersion #-} + +sourceKeys :: EpochDelta keyMap observed -> observed +sourceKeys deltaValue = + endpointKeys (sourceEndpoint deltaValue) +{-# INLINE sourceKeys #-} + +targetKeys :: EpochDelta keyMap observed -> observed +targetKeys deltaValue = + endpointKeys (targetEndpoint deltaValue) +{-# INLINE targetKeys #-} + +transportOverrides :: EpochDelta keyMap observed -> keyMap +transportOverrides = + transportOverride +{-# INLINE transportOverrides #-} + +retiredKeys :: EpochDelta keyMap observed -> observed +retiredKeys = + retiredSourceKeys +{-# INLINE retiredKeys #-} + +transportKeyTotal :: + EpochKeyed keyMap observed => + EpochDelta keyMap observed -> + SetKey observed -> + Maybe (SetKey observed) +transportKeyTotal deltaValue sourceKey + | memberSet sourceKey (retiredSourceKeys deltaValue) = + Nothing + | otherwise = + Just (fromMaybe sourceKey (lookupMap sourceKey (transportOverride deltaValue))) +{-# INLINABLE transportKeyTotal #-} + +survivingTransportImage :: + EpochKeyed keyMap observed => + observed -> + keyMap -> + observed -> + observed +survivingTransportImage sourceKeySet transportMap retiredKeySet = + case (nullMap transportMap, nullSet retiredKeySet) of + (True, True) -> + sourceKeySet + (True, False) -> + differenceSet sourceKeySet retiredKeySet + (False, _) -> + unionSet identitySurvivors transportedTargets + where + transportEntries = + toAscListMap transportMap + identitySurvivors = + differenceSet + (differenceSet sourceKeySet retiredKeySet) + (fromListSet (fmap fst transportEntries)) + transportedTargets = + fromListSet (fmap snd transportEntries) +{-# INLINABLE survivingTransportImage #-} + +freshKeys :: + EpochKeyed keyMap observed => + EpochDelta keyMap observed -> + observed +freshKeys deltaValue = + differenceSet + (targetKeys deltaValue) + ( survivingTransportImage + (sourceKeys deltaValue) + (transportOverride deltaValue) + (retiredSourceKeys deltaValue) + ) +{-# INLINABLE freshKeys #-} + +changedKeysAcrossEpoch :: EpochDelta keyMap observed -> observed +changedKeysAcrossEpoch = + dirtyTargetKeys +{-# INLINE changedKeysAcrossEpoch #-} + +instance + (EpochKeyed keyMap observed, Eq observed) => + DeltaNormalize (EpochDelta keyMap observed) + where + normalizeDelta = + id + + deltaNull deltaValue = + nullMap (transportOverride deltaValue) + && nullSet (retiredSourceKeys deltaValue) + && nullSet (dirtyTargetKeys deltaValue) + && sourceEndpoint deltaValue == targetEndpoint deltaValue + +instance + EpochKeyed keyMap observed => + DeltaSupport (EpochDelta keyMap observed) + where + type DeltaSupportSet (EpochDelta keyMap observed) = observed + + emptySupport = + emptySet + + deltaSupport = + changedKeysAcrossEpoch diff --git a/src-epoch/Moonlight/Delta/Epoch/Internal/Version.hs b/src-epoch/Moonlight/Delta/Epoch/Internal/Version.hs new file mode 100644 --- /dev/null +++ b/src-epoch/Moonlight/Delta/Epoch/Internal/Version.hs @@ -0,0 +1,37 @@ +-- | The unbounded epoch version algebra. +module Moonlight.Delta.Epoch.Internal.Version + ( Version, + initialVersion, + nextVersion, + versionKey, + versionFromKey, + ) +where + +import Data.Kind (Type) +import Moonlight.Core (PartialOrder (..), totalOrderLeq) +import Prelude (Eq, Integer, Num ((+)), Ord, Show) + +type Version :: Type +newtype Version = Version Integer + deriving stock (Eq, Ord, Show) + +initialVersion :: Version +initialVersion = + Version 0 + +nextVersion :: Version -> Version +nextVersion (Version versionValue) = + Version (versionValue + 1) + +versionKey :: Version -> Integer +versionKey (Version versionValue) = + versionValue + +versionFromKey :: Integer -> Version +versionFromKey = + Version + +instance PartialOrder Version where + leq = + totalOrderLeq diff --git a/src-epoch/Moonlight/Delta/Epoch/Internal/View.hs b/src-epoch/Moonlight/Delta/Epoch/Internal/View.hs new file mode 100644 --- /dev/null +++ b/src-epoch/Moonlight/Delta/Epoch/Internal/View.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Version-stamped snapshots. A 'ContextView' carries the claim under which +-- it was taken; 'contextViewIsCurrent' compares claims, nothing more. The +-- with-helpers are the curated vocabulary for restamping — consumers should +-- not reach for record update syntax. +module Moonlight.Delta.Epoch.Internal.View + ( ContextView (..), + viewAt, + viewWithVersion, + viewWithSupport, + viewWithSection, + mapContextViewKeys, + contextViewIsCurrent, + contextViewIsStale, + ) +where + +import Data.Kind (Type) +import Moonlight.Core (OrdSet (..)) +import Moonlight.Delta.Epoch.Internal.Version (Version) +import Prelude (Bool, Eq ((==)), Ord, Show, fmap, not, (.)) + +type ContextView :: Type -> Type -> Type +data ContextView observed section = ContextView + { cvVersion :: !Version, + cvObservedKeys :: !observed, + cvSection :: !section + } + deriving stock (Eq, Ord, Show) + +viewAt :: Version -> observed -> section -> ContextView observed section +viewAt = + ContextView + +viewWithVersion :: Version -> ContextView observed section -> ContextView observed section +viewWithVersion epochVersion contextView = + contextView + { cvVersion = epochVersion + } + +viewWithSupport :: observed -> ContextView observed section -> ContextView observed section +viewWithSupport observedKeys contextView = + contextView + { cvObservedKeys = observedKeys + } + +viewWithSection :: section -> ContextView observed section -> ContextView observed section +viewWithSection sectionValue contextView = + contextView + { cvSection = sectionValue + } + +mapContextViewKeys :: + (OrdSet observed1, OrdSet observed2) => + (SetKey observed1 -> SetKey observed2) -> + ContextView observed1 section -> + ContextView observed2 section +mapContextViewKeys rekey contextView = + ContextView + { cvVersion = cvVersion contextView, + cvObservedKeys = fromListSet (fmap rekey (toAscListSet (cvObservedKeys contextView))), + cvSection = cvSection contextView + } + +contextViewIsCurrent :: Version -> ContextView observed section -> Bool +contextViewIsCurrent epochVersion contextView = + cvVersion contextView == epochVersion + +contextViewIsStale :: Version -> ContextView observed section -> Bool +contextViewIsStale epochVersion = + not . contextViewIsCurrent epochVersion diff --git a/src-patch-public/Moonlight/Delta/Patch.hs b/src-patch-public/Moonlight/Delta/Patch.hs new file mode 100644 --- /dev/null +++ b/src-patch-public/Moonlight/Delta/Patch.hs @@ -0,0 +1,145 @@ +module Moonlight.Delta.Patch + ( CellPatch, + PatchKey, + PatchValue, + Patch, + ApplyError (..), + ComposeError (..), + ReplayError (..), + MerkleDeltaHash, + MultisetDeltaHash, + Digest128, + DeltaHashDigest (..), + DeltaHashBuildError (..), + DeltaHashApplyError (..), + assertAbsent, + insert, + delete, + replace, + matchCell, + cellBefore, + cellAfter, + -- | Build a cell patch from observable before and after endpoints. + -- + -- @Nothing@ means the key is absent on that side; @Just value@ means the + -- key is present with that value. + cellFromEndpoints, + mapCell, + traverseCell, + empty, + singleton, + -- | Build a patch from an authoritative final map of logical rows. + -- + -- Duplicate keys use the same last-wins semantics as 'Data.Map.Strict.fromList'. + -- Use 'recordMany' for a temporal edit log whose repeated keys must stitch + -- through matching before/after boundaries. + fromList, + -- | Build from an ascending logical-row list when possible, falling back + -- to 'fromList' for non-ascending input. Repeated adjacent keys are treated + -- as authoritative replacement rows, not as a temporal edit sequence. + fromAscList, + toAscList, + lookup, + mapMaybeWithKey, + foldWithKey, + foldWithKey', + traverseWithKey, + normalize, + null, + size, + support, + compose, + recordApplied, + -- | Record a batch of applied edits as a temporal edit log. + -- + -- Repeated keys must form a valid chain: each later before endpoint must + -- equal the previous after endpoint. Boundary mismatches are reported as + -- 'ComposeBoundaryMismatch'. + recordMany, + invert, + diff, + apply, + replay, + buildMerkleDeltaHash, + merkleDeltaHashState, + merkleDeltaHashDigest, + applyMerkleDeltaHash, + buildMultisetDeltaHash, + multisetDeltaHashState, + multisetDeltaHashDigest, + applyMultisetDeltaHash, + ) +where + +import Moonlight.Delta.Patch.Internal.Apply + ( apply, + ) +import Moonlight.Delta.Patch.Internal.Cell + ( assertAbsent, + cellAfter, + cellBefore, + cellFromEndpoints, + delete, + insert, + mapCell, + matchCell, + replace, + traverseCell, + ) +import Moonlight.Delta.Patch.Internal.Compose.Core + ( compose, + ) +import Moonlight.Delta.Patch.Internal.Compose.Record + ( recordApplied, + recordMany, + ) +import Moonlight.Delta.Patch.Internal.Construction + ( diff, + empty, + foldWithKey, + foldWithKey', + fromAscList, + fromList, + invert, + lookup, + mapMaybeWithKey, + singleton, + toAscList, + traverseWithKey, + ) +import Moonlight.Delta.Patch.Internal.Replay + ( replay, + ) +import Moonlight.Delta.Patch.Internal.IncrementalDigest + ( DeltaHashApplyError (..), + DeltaHashBuildError (..), + DeltaHashDigest (..), + Digest128, + ) +import Moonlight.Delta.Patch.Internal.MerkleDeltaHash + ( MerkleDeltaHash, + applyMerkleDeltaHash, + buildMerkleDeltaHash, + merkleDeltaHashDigest, + merkleDeltaHashState, + ) +import Moonlight.Delta.Patch.Internal.MultisetDeltaHash + ( MultisetDeltaHash, + applyMultisetDeltaHash, + buildMultisetDeltaHash, + multisetDeltaHashDigest, + multisetDeltaHashState, + ) +import Moonlight.Delta.Patch.Internal.Types + ( ApplyError (..), + CellPatch, + ComposeError (..), + PatchKey, + PatchValue, + Patch, + ReplayError (..), + normalize, + null, + size, + support, + ) diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Apply.hs b/src-patch/Moonlight/Delta/Patch/Internal/Apply.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Apply.hs @@ -0,0 +1,762 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- Loop-local rebinding (state/cursor/coverage) is the engine idiom here; shadowing is deliberate. +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Moonlight.Delta.Patch.Internal.Apply + ( apply, + shouldUseSparse, + applyTrusted, + applyTrustedEdit, + ) +where + +import Data.Bits (testBit) +import Data.List qualified as List +-- Data.Map.Internal: balance-aware spine traversal; semi-stable API accepted deliberately, pinned by containers < 0.9. +import Data.Map.Internal qualified as MapInternal +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Primitive.SmallArray + ( SmallArray, + indexSmallArray, + sizeofSmallArray, + ) +import Data.Word (Word64) +import Moonlight.Delta.Patch.Internal.Cell +import Moonlight.Delta.Patch.Internal.Cursor +import Moonlight.Delta.Patch.Internal.Page +import Moonlight.Delta.Patch.Internal.Types +import Prelude hiding (null) + +data EditResult key value + = EditUnchanged + | EditChanged !(Map key value) + +data MergeCursor key value = MergeCursor !(AscCursor key value) !(Cursor key value) + +data MergeOutput key value = MergeOutput !key !value !(MergeCursor key value) + +data BuildResult key value = BuildResult !(Map key value) !(MergeCursor key value) + +apply :: + forall key value. + (Ord key, Eq value) => + Patch key value -> + Map key value -> + Either (ApplyError key value) (Map key value) +apply patch state = + case patch of + SmallPatch cells -> + applySmall cells state + PagedPatch _count _pages -> + case applyAlignedWhole patch state of + Left failure -> + Left failure + Right (Just result) -> + Right result + Right Nothing + | useSparsePlan patch state -> + applySparse patch state + | otherwise -> + applyDense patch state +{-# INLINABLE apply #-} + +applySmall :: + forall key value. + (Ord key, Eq value) => + SmallArray (Cell key value) -> + Map key value -> + Either (ApplyError key value) (Map key value) +applySmall cells state = + go 0 state + where + !count = sizeofSmallArray cells + + go :: Int -> Map key value -> Either (ApplyError key value) (Map key value) + go !index !current + | index == count = + Right current + | otherwise = + case indexSmallArray cells index of + Cell key cell -> do + result <- checkedEdit key (cellBeforeEndpoint cell) (cellAfterEndpoint cell) current + case result of + EditUnchanged -> + go (index + 1) current + EditChanged changed -> + go (index + 1) changed +{-# INLINABLE applySmall #-} + +useSparsePlan :: Patch key value -> Map key value -> Bool +useSparsePlan patch state = + shouldUseSparse (Map.size state) (entryCount patch) +{-# INLINE useSparsePlan #-} + +shouldUseSparse :: Int -> Int -> Bool +shouldUseSparse stateSize patchSize + | patchSize <= 64 = + True + | stateSize <= 0 = + False + | otherwise = + patchSize <= stateSize `quot` (mapLookupFactor (stateSize + 1) + 6) +{-# INLINE shouldUseSparse #-} + +mapLookupFactor :: Int -> Int +mapLookupFactor value = + go 0 value + where + go :: Int -> Int -> Int + go !result remaining + | remaining <= 1 = result + | otherwise = go (result + 1) (remaining `quot` 2) +{-# INLINE mapLookupFactor #-} + +applySparse :: + forall key value. + (Ord key, Eq value) => + Patch key value -> + Map key value -> + Either (ApplyError key value) (Map key value) +applySparse patch state = do + (!appliedPrefix, !remainingState) <- applySparsePages (pagesOf patch) Map.empty state + pure (appendOrdered appliedPrefix remainingState) +{-# INLINABLE applySparse #-} + +applySparsePages :: + forall key value. + (Ord key, Eq value) => + Map key (Page key value) -> + Map key value -> + Map key value -> + Either (ApplyError key value) (Map key value, Map key value) +applySparsePages MapInternal.Tip !accumulated !remaining = + Right (accumulated, remaining) +applySparsePages (MapInternal.Bin _ maximumKey page left right) !accumulated !remaining = do + (!afterLeft, !remainingAfterLeft) <- applySparsePages left accumulated remaining + let !minimumKey = pageMinimumKey maximumKey page + (!untouched, !atOrAfterMinimum) = splitLessThan minimumKey remainingAfterLeft + (!localState, !remainingAfterPage) = splitLessOrEqual maximumKey atOrAfterMinimum + if shouldMergePage page localState + then do + !localResult <- applyOnePage maximumKey page localState + let !afterPage = + appendOrdered afterLeft (appendOrdered untouched localResult) + applySparsePages right afterPage remainingAfterPage + else do + !updatedRemaining <- + applySparsePagePointwise + maximumKey + page + (appendOrdered untouched (appendOrdered localState remainingAfterPage)) + applySparsePages right afterLeft updatedRemaining +{-# INLINABLE applySparsePages #-} + +shouldMergePage :: Page key value -> Map key value -> Bool +shouldMergePage page localState = + let !localSize = Map.size localState + !pageSize = pageCount page + in localSize <= pageSize * (mapLookupFactor (localSize + 1) + 8) +{-# INLINE shouldMergePage #-} + +applySparsePagePointwise :: + forall key value. + (Ord key, Eq value) => + key -> + Page key value -> + Map key value -> + Either (ApplyError key value) (Map key value) +applySparsePagePointwise maximumKey page = + case + ( columnView count (pageBeforeColumn page), + columnView count (pageAfterColumn page) + ) + of + (ColumnView beforeMask beforeValues, ColumnView afterMask afterValues) -> + go 0 0 0 beforeMask beforeValues afterMask afterValues + where + !count = pageCount page + + go :: Int -> Int -> Int -> Word64 -> ValueColumn value -> Word64 -> ValueColumn value -> Map key value -> Either (ApplyError key value) (Map key value) + go !index !beforePacked !afterPacked !beforeMask !beforeValues !afterMask !afterValues !state + | index == count = + Right state + | otherwise = do + let !patchKey = pageKeyAt maximumKey page index + !beforePresent = testBit beforeMask index + !afterPresent = testBit afterMask index + !before = + if beforePresent + then EndpointPresent (valueColumnAt beforeValues beforePacked) + else EndpointAbsent + !after = + if afterPresent + then EndpointPresent (valueColumnAt afterValues afterPacked) + else EndpointAbsent + !nextBeforePacked = + if beforePresent + then beforePacked + 1 + else beforePacked + !nextAfterPacked = + if afterPresent + then afterPacked + 1 + else afterPacked + result <- checkedEdit patchKey before after state + let !nextState = + case result of + EditUnchanged -> + state + EditChanged changed -> + changed + go (index + 1) nextBeforePacked nextAfterPacked beforeMask beforeValues afterMask afterValues nextState +{-# INLINABLE applySparsePagePointwise #-} + +applyOnePage :: + forall key value. + (Ord key, Eq value) => + key -> + Page key value -> + Map key value -> + Either (ApplyError key value) (Map key value) +applyOnePage maximumKey page state = + case + ( columnView count (pageBeforeColumn page), + columnView count (pageAfterColumn page) + ) + of + (ColumnView beforeMask beforeValues, ColumnView afterMask afterValues) -> + Map.fromDistinctAscList <$> merge beforeMask beforeValues afterMask afterValues 0 0 0 (Map.toAscList state) [] + where + !count = pageCount page + + merge !_beforeMask !_beforeValues !_afterMask !_afterValues !logicalIndex !_beforePacked !_afterPacked stateRows !reversedOutput + | logicalIndex == count = + Right (List.reverse reversedOutput <> stateRows) + merge !beforeMask !beforeValues !afterMask !afterValues !logicalIndex !beforePacked !afterPacked stateRows !reversedOutput = + let !patchKey = pageKeyAt maximumKey page logicalIndex + !beforePresent = testBit beforeMask logicalIndex + !afterPresent = testBit afterMask logicalIndex + !expected = + if beforePresent + then EndpointPresent (valueColumnAt beforeValues beforePacked) + else EndpointAbsent + !after = + if afterPresent + then EndpointPresent (valueColumnAt afterValues afterPacked) + else EndpointAbsent + !nextBeforePacked = + if beforePresent + then beforePacked + 1 + else beforePacked + !nextAfterPacked = + if afterPresent + then afterPacked + 1 + else afterPacked + continue = + merge + beforeMask + beforeValues + afterMask + afterValues + (logicalIndex + 1) + nextBeforePacked + nextAfterPacked + in case stateRows of + [] -> do + output <- applyEndpoints patchKey expected after EndpointAbsent + continue [] (prependOutput output reversedOutput) + rows@((stateKey, stateValue) : stateRest) -> + case compare patchKey stateKey of + LT -> do + output <- applyEndpoints patchKey expected after EndpointAbsent + continue rows (prependOutput output reversedOutput) + GT -> + merge + beforeMask + beforeValues + afterMask + afterValues + logicalIndex + beforePacked + afterPacked + stateRest + ((stateKey, stateValue) : reversedOutput) + EQ -> do + output <- applyEndpoints patchKey expected after (EndpointPresent stateValue) + continue stateRest (prependOutput output reversedOutput) + + prependOutput :: Maybe row -> [row] -> [row] + prependOutput Nothing rows = + rows + prependOutput (Just row) rows = + row : rows +{-# INLINABLE applyOnePage #-} + +applyEndpoints :: + Eq value => + key -> + Endpoint value -> + Endpoint value -> + Endpoint value -> + Either (ApplyError key value) (Maybe (key, value)) +applyEndpoints patchKey expected after actual = + if expected == actual + then + Right + ( case after of + EndpointAbsent -> + Nothing + EndpointPresent value -> + Just (patchKey, value) + ) + else + Left + ApplyBeforeMismatch + { mismatchKey = patchKey, + expectedBefore = endpointToMaybe expected, + actualBefore = endpointToMaybe actual + } +{-# INLINE applyEndpoints #-} + +appendOrdered :: Map key value -> Map key value -> Map key value +appendOrdered left right = + case (left, right) of + (MapInternal.Tip, _) -> + right + (_, MapInternal.Tip) -> + left + _ -> + MapInternal.link2 left right +{-# INLINE appendOrdered #-} + +splitLessThan :: Ord key => key -> Map key value -> (Map key value, Map key value) +splitLessThan key entries = + case Map.splitLookup key entries of + (less, Nothing, greater) -> + (less, greater) + (less, Just value, greater) -> + (less, Map.insert key value greater) +{-# INLINE splitLessThan #-} + +splitLessOrEqual :: Ord key => key -> Map key value -> (Map key value, Map key value) +splitLessOrEqual key entries = + case Map.splitLookup key entries of + (less, Nothing, greater) -> + (less, greater) + (less, Just value, greater) -> + (Map.insert key value less, greater) +{-# INLINE splitLessOrEqual #-} + +applyAlignedWhole :: + forall key value. + (Ord key, Eq value) => + Patch key value -> + Map key value -> + Either (ApplyError key value) (Maybe (Map key value)) +applyAlignedWhole patch state + | entryCount patch /= Map.size state = + Right Nothing + | otherwise = do + result <- rebuild state (cursor (pagesOf patch)) + case result of + Nothing -> + Right Nothing + Just (!tree, !remainingPatch) -> + case remainingPatch of + CursorEnd -> + Right (Just tree) + _activeCursor -> + Right Nothing + where + rebuild :: + Map key value -> + Cursor key value -> + Either (ApplyError key value) (Maybe (Map key value, Cursor key value)) + rebuild MapInternal.Tip cursor = + Right (Just (MapInternal.Tip, cursor)) + rebuild (MapInternal.Bin stateCount stateKey stateValue left right) cursor = do + maybeLeft <- rebuild left cursor + case maybeLeft of + Nothing -> + Right Nothing + Just (!rebuiltLeft, !afterLeft) -> + case currentKey afterLeft of + Just patchKey -> + case compare patchKey stateKey of + EQ -> + case beforeMaybe afterLeft of + Just expected + | expected == stateValue -> + case afterMaybe afterLeft of + Nothing -> + Right Nothing + Just afterValue -> do + maybeRight <- rebuild right (advanceRow afterLeft) + case maybeRight of + Nothing -> + Right Nothing + Just (!rebuiltRight, !afterRight) -> + Right + ( Just + ( MapInternal.Bin stateCount patchKey afterValue rebuiltLeft rebuiltRight, + afterRight + ) + ) + maybeExpected -> + Left + ApplyBeforeMismatch + { mismatchKey = patchKey, + expectedBefore = maybeExpected, + actualBefore = Just stateValue + } + _ -> + Right Nothing + Nothing -> + Right Nothing +{-# INLINABLE applyAlignedWhole #-} + +checkedEdit :: + forall key value. + (Ord key, Eq value) => + key -> + Endpoint value -> + Endpoint value -> + Map key value -> + Either (ApplyError key value) (EditResult key value) +checkedEdit patchKey before after = + descend + where + !expected = endpointToMaybe before + + descend entries = + case entries of + MapInternal.Tip -> + case expected of + Just _ -> + Left (ApplyBeforeMismatch patchKey expected Nothing) + Nothing -> + case after of + EndpointAbsent -> + Right EditUnchanged + EndpointPresent newValue -> + Right (EditChanged (Map.singleton patchKey newValue)) + MapInternal.Bin nodeSize existingKey existingValue left right -> + case compare patchKey existingKey of + LT -> do + result <- descend left + pure + ( case result of + EditUnchanged -> EditUnchanged + EditChanged changedLeft -> EditChanged (MapInternal.link existingKey existingValue changedLeft right) + ) + GT -> do + result <- descend right + pure + ( case result of + EditUnchanged -> EditUnchanged + EditChanged changedRight -> EditChanged (MapInternal.link existingKey existingValue left changedRight) + ) + EQ + | expected /= Just existingValue -> + Left (ApplyBeforeMismatch patchKey expected (Just existingValue)) + | otherwise -> + case after of + EndpointAbsent -> + Right (EditChanged (MapInternal.link2 left right)) + EndpointPresent newValue -> + Right (EditChanged (MapInternal.Bin nodeSize patchKey newValue left right)) +{-# INLINABLE checkedEdit #-} + +applyDense :: + forall key value. + (Ord key, Eq value) => + Patch key value -> + Map key value -> + Either (ApplyError key value) (Map key value) +applyDense patch state = + case applyOutputCountCandidate patch state of + Nothing -> + applySparse patch state + Just outputCount -> + case buildCheckedApplyMap outputCount initialCursor of + Left failure -> + Left failure + Right Nothing -> + applySparse patch state + Right (Just (BuildResult result remaining)) -> + case drainCheckedApplyCursor remaining of + Left failure -> + Left failure + Right True -> + Right result + Right False -> + applySparse patch state + where + !initialCursor = + MergeCursor (ascCursor state) (cursor (pagesOf patch)) +{-# INLINABLE applyDense #-} + +applyOutputCountCandidate :: Patch key value -> Map key value -> Maybe Int +applyOutputCountCandidate patch state = + let !outputCount = Map.size state + netSizeDelta patch + in if outputCount < 0 then Nothing else Just outputCount +{-# INLINE applyOutputCountCandidate #-} + +buildCheckedApplyMap :: + (Ord key, Eq value) => + Int -> + MergeCursor key value -> + Either (ApplyError key value) (Maybe (BuildResult key value)) +buildCheckedApplyMap !outputCount cursor + | outputCount <= 0 = + Right (Just (BuildResult MapInternal.Tip cursor)) + | otherwise = do + let !leftCount = outputCount `quot` 2 + !rightCount = outputCount - leftCount - 1 + maybeLeft <- buildCheckedApplyMap leftCount cursor + case maybeLeft of + Nothing -> + Right Nothing + Just (BuildResult left afterLeft) -> do + maybeMiddle <- nextApplyChecked afterLeft + case maybeMiddle of + Nothing -> + Right Nothing + Just (MergeOutput key value afterMiddle) -> do + maybeRight <- buildCheckedApplyMap rightCount afterMiddle + case maybeRight of + Nothing -> + Right Nothing + Just (BuildResult right afterRight) -> + Right (Just (BuildResult (MapInternal.Bin outputCount key value left right) afterRight)) +{-# INLINABLE buildCheckedApplyMap #-} + +drainCheckedApplyCursor :: + (Ord key, Eq value) => + MergeCursor key value -> + Either (ApplyError key value) Bool +drainCheckedApplyCursor cursor = + case nextApplyChecked cursor of + Left failure -> + Left failure + Right Nothing -> + Right True + Right (Just _) -> + Right False +{-# INLINABLE drainCheckedApplyCursor #-} + +buildTrustedApplyMap :: Ord key => Int -> MergeCursor key value -> Maybe (BuildResult key value) +buildTrustedApplyMap !outputCount cursor + | outputCount <= 0 = + Just (BuildResult MapInternal.Tip cursor) + | otherwise = do + let !leftCount = outputCount `quot` 2 + !rightCount = outputCount - leftCount - 1 + BuildResult left afterLeft <- buildTrustedApplyMap leftCount cursor + MergeOutput key value afterMiddle <- nextApplyTrusted afterLeft + BuildResult right afterRight <- buildTrustedApplyMap rightCount afterMiddle + Just (BuildResult (MapInternal.Bin outputCount key value left right) afterRight) +{-# INLINABLE buildTrustedApplyMap #-} + +nextApplyChecked :: + forall key value. + (Ord key, Eq value) => + MergeCursor key value -> + Either (ApplyError key value) (Maybe (MergeOutput key value)) +nextApplyChecked (MergeCursor stateCursor cursor') = + case (stateCursor, cursor') of + (AscEnd, CursorEnd) -> + Right Nothing + (AscCursor stateKey stateValue _ _, CursorEnd) -> + Right (Just (MergeOutput stateKey stateValue (MergeCursor (ascAdvance stateCursor) CursorEnd))) + (AscEnd, _) -> + consumeAbsentStateRow AscEnd cursor' + (AscCursor stateKey stateValue _ _, _) -> + case currentKey cursor' of + Nothing -> + Right (Just (MergeOutput stateKey stateValue (MergeCursor (ascAdvance stateCursor) cursor'))) + Just patchKey -> + case compare stateKey patchKey of + LT -> + Right (Just (MergeOutput stateKey stateValue (MergeCursor (ascAdvance stateCursor) cursor'))) + GT -> + consumeAbsentStateRow stateCursor cursor' + EQ -> + let !expected = beforeMaybe cursor' + in if expected /= Just stateValue + then Left (ApplyBeforeMismatch patchKey expected (Just stateValue)) + else emitPatchAfter patchKey (MergeCursor (ascAdvance stateCursor) (advanceRow cursor')) cursor' + where + consumeAbsentStateRow :: + AscCursor key value -> + Cursor key value -> + Either (ApplyError key value) (Maybe (MergeOutput key value)) + consumeAbsentStateRow stateCursor' cursor = + case currentKey cursor of + Nothing -> + Right Nothing + Just key -> + case beforeMaybe cursor of + Just expected -> + Left (ApplyBeforeMismatch key (Just expected) Nothing) + Nothing -> + emitPatchAfter key (MergeCursor stateCursor' (advanceRow cursor)) cursor + + emitPatchAfter :: + key -> + MergeCursor key value -> + Cursor key value -> + Either (ApplyError key value) (Maybe (MergeOutput key value)) + emitPatchAfter key nextCursor cursor = + case afterMaybe cursor of + Nothing -> + nextApplyChecked nextCursor + Just value -> + Right (Just (MergeOutput key value nextCursor)) +{-# INLINABLE nextApplyChecked #-} + +nextApplyTrusted :: forall key value. Ord key => MergeCursor key value -> Maybe (MergeOutput key value) +nextApplyTrusted (MergeCursor stateCursor cursor') = + case (stateCursor, cursor') of + (AscEnd, CursorEnd) -> + Nothing + (AscCursor stateKey stateValue _ _, CursorEnd) -> + Just (MergeOutput stateKey stateValue (MergeCursor (ascAdvance stateCursor) CursorEnd)) + (AscEnd, _) -> + emitTrustedPatchRow AscEnd cursor' + (AscCursor stateKey stateValue _ _, _) -> + case currentKey cursor' of + Nothing -> + Just (MergeOutput stateKey stateValue (MergeCursor (ascAdvance stateCursor) cursor')) + Just patchKey -> + case compare stateKey patchKey of + LT -> + Just (MergeOutput stateKey stateValue (MergeCursor (ascAdvance stateCursor) cursor')) + GT -> + emitTrustedPatchRow stateCursor cursor' + EQ -> + emitTrustedPatchRow (ascAdvance stateCursor) cursor' + where + emitTrustedPatchRow :: AscCursor key value -> Cursor key value -> Maybe (MergeOutput key value) + emitTrustedPatchRow stateCursor' cursor = + case currentKey cursor of + Nothing -> + Nothing + Just key -> + let !nextCursor = + MergeCursor stateCursor' (advanceRow cursor) + in case afterMaybe cursor of + Nothing -> + nextApplyTrusted nextCursor + Just value -> + Just (MergeOutput key value nextCursor) +{-# INLINABLE nextApplyTrusted #-} + + +applyTrusted :: Ord key => Patch key value -> Map key value -> Map key value +applyTrusted patch state = + case patch of + SmallPatch cells -> + applyTrustedSmall cells state + PagedPatch _count _pages + | useSparsePlan patch state -> + applyTrustedPointwise patch state + | otherwise -> + applyTrustedDense patch state + +applyTrustedSmall :: Ord key => SmallArray (Cell key value) -> Map key value -> Map key value +applyTrustedSmall cells state = + go 0 state + where + !count = sizeofSmallArray cells + + go !index !current + | index == count = + current + | otherwise = + case indexSmallArray cells index of + Cell key cell -> + go (index + 1) (applyTrustedEdit key (cellAfter cell) current) +{-# INLINABLE applyTrustedSmall #-} + +applyTrustedDense :: forall key value. Ord key => Patch key value -> Map key value -> Map key value +applyTrustedDense patch state = + case applyOutputCountCandidate patch state of + Nothing -> + applyTrustedPointwise patch state + Just outputCount -> + case buildTrustedApplyMap outputCount initialCursor of + Just (BuildResult result remaining) + | drainTrustedApplyCursor remaining -> + result + _ -> + applyTrustedPointwise patch state + where + !initialCursor = + MergeCursor (ascCursor state) (cursor (pagesOf patch)) +{-# INLINABLE applyTrustedDense #-} + +drainTrustedApplyCursor :: Ord key => MergeCursor key value -> Bool +drainTrustedApplyCursor cursor = + case nextApplyTrusted cursor of + Nothing -> + True + Just _ -> + False +{-# INLINABLE drainTrustedApplyCursor #-} + +applyTrustedPointwise :: forall key value. Ord key => Patch key value -> Map key value -> Map key value +applyTrustedPointwise patch = + go (cursor (pagesOf patch)) + where + go :: Cursor key value -> Map key value -> Map key value + go CursorEnd !state = + state + go cursor !state = + case currentKey cursor of + Nothing -> + state + Just key -> + go (advanceRow cursor) (applyTrustedEdit key (afterMaybe cursor) state) +{-# INLINABLE applyTrustedPointwise #-} + +applyTrustedEdit :: Ord key => key -> Maybe value -> Map key value -> Map key value +applyTrustedEdit patchKey after initialEntries = + case descend initialEntries of + EditUnchanged -> + initialEntries + EditChanged changed -> + changed + where + descend currentEntries = + case currentEntries of + MapInternal.Tip -> + case after of + Nothing -> + EditUnchanged + Just newValue -> + EditChanged (Map.singleton patchKey newValue) + MapInternal.Bin nodeSize existingKey existingValue left right -> + case compare patchKey existingKey of + LT -> + case descend left of + EditUnchanged -> + EditUnchanged + EditChanged changedLeft -> + EditChanged (MapInternal.link existingKey existingValue changedLeft right) + GT -> + case descend right of + EditUnchanged -> + EditUnchanged + EditChanged changedRight -> + EditChanged (MapInternal.link existingKey existingValue left changedRight) + EQ -> + case after of + Nothing -> + EditChanged (MapInternal.link2 left right) + Just newValue -> + EditChanged (MapInternal.Bin nodeSize patchKey newValue left right) +{-# INLINABLE applyTrustedEdit #-} diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Builder.hs b/src-patch/Moonlight/Delta/Patch/Internal/Builder.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Builder.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- Loop-local rebinding (state/cursor/coverage) is the engine idiom here; shadowing is deliberate. +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Moonlight.Delta.Patch.Internal.Builder + ( Builder, + newBuilder, + appendTransition, + appendPageCopy, + finishBuilder, + toPaged, + toPagedMap, + ) +where + +import Control.Monad.ST (ST, runST) +import Data.Bits (setBit, testBit) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Primitive.PrimArray + ( MutablePrimArray, + newPrimArray, + readPrimArray, + writePrimArray, + ) +import Data.Primitive.SmallArray + ( SmallArray, + SmallMutableArray, + copySmallMutableArray, + emptySmallArray, + indexSmallArray, + newSmallArray, + readSmallArray, + sizeofSmallArray, + unsafeFreezeSmallArray, + writeSmallArray, + ) +import Data.STRef + ( STRef, + modifySTRef', + newSTRef, + readSTRef, + writeSTRef, + ) +import Data.Word (Word64) +import Moonlight.Delta.Patch.Internal.Cell + ( cellAfterEndpoint, + cellBeforeEndpoint, + ) +import Moonlight.Delta.Patch.Internal.Page + ( ColumnView (..), + columnView, + ) +import Moonlight.Delta.Patch.Internal.Types + ( Endpoint (..), + EndpointColumn (..), + Cell (..), + PatchKey, + PatchValue, + Patch (..), + Page (..), + buildKeyColumn, + pageKeyAt, + valueColumnAt, + valueColumnFromArray, + ) +import Prelude + +bufferCapacity :: Int +bufferCapacity = 96 +{-# INLINE bufferCapacity #-} + +sealedPrefixSize :: Int +sealedPrefixSize = 64 +{-# INLINE sealedPrefixSize #-} + +retainedSuffixSize :: Int +retainedSuffixSize = 32 +{-# INLINE retainedSuffixSize #-} + +data OpenArrays s key value = OpenArrays + { openKeys :: !(SmallMutableArray s key), + openBefore :: !(SmallMutableArray s (Endpoint value)), + openAfter :: !(SmallMutableArray s (Endpoint value)), + openCount :: !(MutablePrimArray s Int) + } + +data OpenBuffer s key value + = OpenEmpty + | OpenNonEmpty !(OpenArrays s key value) + +data Builder s key value = Builder + { totalCount :: !(MutablePrimArray s Int), + openBuffer :: !(STRef s (OpenBuffer s key value)), + pagesReverse :: !(STRef s [(key, Page key value)]) + } + +newBuilder :: ST s (Builder s key value) +newBuilder = do + totalCount <- newPrimArray 1 + writePrimArray totalCount 0 0 + openBuffer <- newSTRef OpenEmpty + pagesReverse <- newSTRef [] + pure + Builder + { totalCount = totalCount, + openBuffer = openBuffer, + pagesReverse = pagesReverse + } +{-# INLINE newBuilder #-} + +appendTransition :: + (PatchKey key, PatchValue value) => + Builder s key value -> + key -> + Endpoint value -> + Endpoint value -> + ST s () +appendTransition builder@Builder {totalCount, openBuffer} !key !before !after = do + readSTRef openBuffer >>= \case + OpenEmpty -> do + keys <- newSmallArray bufferCapacity key + beforeValues <- newSmallArray bufferCapacity before + afterValues <- newSmallArray bufferCapacity after + count <- newPrimArray 1 + writePrimArray count 0 1 + writeSTRef + openBuffer + ( OpenNonEmpty + OpenArrays + { openKeys = keys, + openBefore = beforeValues, + openAfter = afterValues, + openCount = count + } + ) + OpenNonEmpty arrays -> do + count <- readPrimArray (openCount arrays) 0 + nextIndex <- + if count == bufferCapacity + then do + sealPrefixAndRetainSuffix builder arrays + pure retainedSuffixSize + else pure count + writeSmallArray (openKeys arrays) nextIndex key + writeSmallArray (openBefore arrays) nextIndex before + writeSmallArray (openAfter arrays) nextIndex after + writePrimArray (openCount arrays) 0 (nextIndex + 1) + total <- readPrimArray totalCount 0 + writePrimArray totalCount 0 (total + 1) +{-# INLINE appendTransition #-} + +sealPrefixAndRetainSuffix :: (PatchKey key, PatchValue value) => Builder s key value -> OpenArrays s key value -> ST s () +sealPrefixAndRetainSuffix builder arrays = do + commitRange builder arrays 0 sealedPrefixSize + shiftRetainedSuffix arrays + writePrimArray (openCount arrays) 0 retainedSuffixSize +{-# INLINE sealPrefixAndRetainSuffix #-} + +shiftRetainedSuffix :: OpenArrays s key value -> ST s () +shiftRetainedSuffix OpenArrays {openKeys, openBefore, openAfter} = + go 0 + where + go !index + | index == retainedSuffixSize = + pure () + | otherwise = do + let !sourceIndex = sealedPrefixSize + index + key <- readSmallArray openKeys sourceIndex + before <- readSmallArray openBefore sourceIndex + after <- readSmallArray openAfter sourceIndex + writeSmallArray openKeys index key + writeSmallArray openBefore index before + writeSmallArray openAfter index after + go (index + 1) +{-# INLINE shiftRetainedSuffix #-} + +commitRange :: (PatchKey key, PatchValue value) => Builder s key value -> OpenArrays s key value -> Int -> Int -> ST s () +commitRange Builder {pagesReverse} OpenArrays {openKeys, openBefore, openAfter} !start !rangeLength = + if rangeLength <= 0 + then pure () + else do + let !maximumIndex = start + rangeLength - 1 + !prefixLength = rangeLength - 1 + maximumKey <- readSmallArray openKeys maximumIndex + prefixKeys <- freezeSlice openKeys start prefixLength + beforeColumn <- compressColumn openBefore start rangeLength + afterColumn <- compressColumn openAfter start rangeLength + let !page = + Page + { pageCount = rangeLength, + pagePrefixKeys = buildKeyColumn prefixKeys, + pageBeforeColumn = beforeColumn, + pageAfterColumn = afterColumn + } + modifySTRef' pagesReverse ((maximumKey, page) :) +{-# INLINE commitRange #-} + +freezeSlice :: SmallMutableArray s value -> Int -> Int -> ST s (SmallArray value) +freezeSlice _ _ 0 = + pure emptySmallArray +freezeSlice source !start !rangeLength = do + seed <- readSmallArray source start + target <- newSmallArray rangeLength seed + copySmallMutableArray target 0 source start rangeLength + unsafeFreezeSmallArray target +{-# INLINE freezeSlice #-} + +compressColumn :: forall s value. PatchValue value => SmallMutableArray s (Endpoint value) -> Int -> Int -> ST s (EndpointColumn value) +compressColumn source !start !rangeLength = do + (mask, presentCount, firstPresent) <- scan 0 0 0 Nothing + values <- + case firstPresent of + Nothing -> + pure emptySmallArray + Just seed -> do + target <- newSmallArray presentCount seed + fill target 0 0 + unsafeFreezeSmallArray target + if presentCount == rangeLength + then pure (AllPresent (valueColumnFromArray values)) + else pure (Presence mask (valueColumnFromArray values)) + where + scan :: Int -> Word64 -> Int -> Maybe value -> ST s (Word64, Int, Maybe value) + scan !logicalIndex !mask !presentCount !firstPresent + | logicalIndex == rangeLength = + pure (mask, presentCount, firstPresent) + | otherwise = do + endpoint <- readSmallArray source (start + logicalIndex) + case endpoint of + EndpointAbsent -> + scan (logicalIndex + 1) mask presentCount firstPresent + EndpointPresent value -> + scan + (logicalIndex + 1) + (setBit mask logicalIndex) + (presentCount + 1) + (case firstPresent of Nothing -> Just value; Just existing -> Just existing) + + fill :: SmallMutableArray s value -> Int -> Int -> ST s () + fill target !logicalIndex !packedIndex + | logicalIndex == rangeLength = + pure () + | otherwise = do + endpoint <- readSmallArray source (start + logicalIndex) + case endpoint of + EndpointAbsent -> + fill target (logicalIndex + 1) packedIndex + EndpointPresent value -> do + writeSmallArray target packedIndex value + fill target (logicalIndex + 1) (packedIndex + 1) +{-# INLINE compressColumn #-} + +appendPageCopy :: (PatchKey key, PatchValue value) => Builder s key value -> key -> Page key value -> ST s () +appendPageCopy builder maximumKey page = + case + ( columnView (pageCount page) (pageBeforeColumn page), + columnView (pageCount page) (pageAfterColumn page) + ) + of + (ColumnView beforeMask beforeValues, ColumnView afterMask afterValues) -> + go 0 0 0 beforeMask beforeValues afterMask afterValues + where + go !logicalIndex !beforePackedIndex !afterPackedIndex !beforeMask !beforeValues !afterMask !afterValues + | logicalIndex == pageCount page = + pure () + | otherwise = do + let !key = pageKeyAt maximumKey page logicalIndex + !beforePresent = testBit beforeMask logicalIndex + !afterPresent = testBit afterMask logicalIndex + !before = + if beforePresent + then EndpointPresent (valueColumnAt beforeValues beforePackedIndex) + else EndpointAbsent + !after = + if afterPresent + then EndpointPresent (valueColumnAt afterValues afterPackedIndex) + else EndpointAbsent + !nextBeforePackedIndex = + if beforePresent + then beforePackedIndex + 1 + else beforePackedIndex + !nextAfterPackedIndex = + if afterPresent + then afterPackedIndex + 1 + else afterPackedIndex + appendTransition builder key before after + go + (logicalIndex + 1) + nextBeforePackedIndex + nextAfterPackedIndex + beforeMask + beforeValues + afterMask + afterValues +{-# INLINE appendPageCopy #-} + +finishBuilderPages :: + (PatchKey key, PatchValue value) => + Builder s key value -> + ST s (Int, Map key (Page key value)) +finishBuilderPages builder@Builder {totalCount, openBuffer, pagesReverse} = do + readSTRef openBuffer >>= \case + OpenEmpty -> + pure () + OpenNonEmpty arrays -> do + count <- readPrimArray (openCount arrays) 0 + if count <= sealedPrefixSize + then commitRange builder arrays 0 count + else do + let !leftCount = count - retainedSuffixSize + commitRange builder arrays 0 leftCount + commitRange builder arrays leftCount retainedSuffixSize + totalCount <- readPrimArray totalCount 0 + pagesReverse <- readSTRef pagesReverse + pure (totalCount, Map.fromDistinctAscList (reverse pagesReverse)) +{-# INLINE finishBuilderPages #-} + +finishBuilder :: (PatchKey key, PatchValue value) => Builder s key value -> ST s (Patch key value) +finishBuilder builder = do + (totalCount, pages) <- finishBuilderPages builder + pure (PagedPatch totalCount pages) +{-# INLINE finishBuilder #-} + +promoteCells :: + (PatchKey key, PatchValue value) => + SmallArray (Cell key value) -> + (Int, Map key (Page key value)) +promoteCells cells = + runST $ do + builder <- newBuilder + appendSmallCells builder cells 0 (sizeofSmallArray cells) + finishBuilderPages builder +{-# INLINABLE promoteCells #-} + +appendSmallCells :: + (PatchKey key, PatchValue value) => + Builder s key value -> + SmallArray (Cell key value) -> + Int -> + Int -> + ST s () +appendSmallCells builder cells !index !count + | index == count = + pure () + | otherwise = + case indexSmallArray cells index of + Cell key cell -> do + appendTransition builder key (cellBeforeEndpoint cell) (cellAfterEndpoint cell) + appendSmallCells builder cells (index + 1) count +{-# INLINABLE appendSmallCells #-} + +toPaged :: (PatchKey key, PatchValue value) => Patch key value -> Patch key value +toPaged patch = + case patch of + PagedPatch _count _pages -> + patch + SmallPatch cells -> + let (!count, !pages) = promoteCells cells + in PagedPatch count pages +{-# INLINABLE toPaged #-} + +toPagedMap :: (PatchKey key, PatchValue value) => Patch key value -> Map key (Page key value) +toPagedMap patch = + case patch of + PagedPatch _count pages -> + pages + SmallPatch cells -> + snd (promoteCells cells) +{-# INLINABLE toPagedMap #-} diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Cell.hs b/src-patch/Moonlight/Delta/Patch/Internal/Cell.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Cell.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Moonlight.Delta.Patch.Internal.Cell + ( assertAbsent, + insert, + delete, + replace, + matchCell, + cellBefore, + cellAfter, + cellBeforeEndpoint, + cellAfterEndpoint, + endpointToMaybe, + cellFromEndpointPair, + cellFromEndpoints, + mapCell, + traverseCell, + ) +where + +import Prelude +import Moonlight.Delta.Patch.Internal.Types + +assertAbsent :: CellPatch value +assertAbsent = + AssertAbsent +{-# INLINE assertAbsent #-} + +insert :: value -> CellPatch value +insert = + Insert +{-# INLINE insert #-} + +delete :: value -> CellPatch value +delete = + Delete +{-# INLINE delete #-} + +replace :: value -> value -> CellPatch value +replace = + Replace +{-# INLINE replace #-} + +matchCell :: + result -> + (value -> result) -> + (value -> result) -> + (value -> value -> result) -> + CellPatch value -> + result +matchCell onAssertAbsent onInsert onDelete onReplace cell = + case cell of + AssertAbsent -> + onAssertAbsent + Insert value -> + onInsert value + Delete value -> + onDelete value + Replace before after -> + onReplace before after +{-# INLINE matchCell #-} + +cellBefore :: CellPatch value -> Maybe value +cellBefore = + matchCell Nothing (const Nothing) Just (\before _after -> Just before) +{-# INLINE cellBefore #-} + +cellAfter :: CellPatch value -> Maybe value +cellAfter = + matchCell Nothing Just (const Nothing) (\_before after -> Just after) +{-# INLINE cellAfter #-} + +cellBeforeEndpoint :: CellPatch value -> Endpoint value +cellBeforeEndpoint cell = + case cell of + AssertAbsent -> + EndpointAbsent + Insert _after -> + EndpointAbsent + Delete before -> + EndpointPresent before + Replace before _after -> + EndpointPresent before +{-# INLINE cellBeforeEndpoint #-} + +cellAfterEndpoint :: CellPatch value -> Endpoint value +cellAfterEndpoint cell = + case cell of + AssertAbsent -> + EndpointAbsent + Insert after -> + EndpointPresent after + Delete _before -> + EndpointAbsent + Replace _before after -> + EndpointPresent after +{-# INLINE cellAfterEndpoint #-} + +endpointToMaybe :: Endpoint value -> Maybe value +endpointToMaybe endpoint = + case endpoint of + EndpointAbsent -> + Nothing + EndpointPresent value -> + Just value +{-# INLINE endpointToMaybe #-} + +cellFromEndpointPair :: + Endpoint value -> + Endpoint value -> + CellPatch value +cellFromEndpointPair before after = + case (before, after) of + (EndpointAbsent, EndpointAbsent) -> + AssertAbsent + (EndpointAbsent, EndpointPresent value) -> + Insert value + (EndpointPresent value, EndpointAbsent) -> + Delete value + (EndpointPresent beforeValue, EndpointPresent afterValue) -> + Replace beforeValue afterValue +{-# INLINE cellFromEndpointPair #-} + +cellFromEndpoints :: + Maybe value -> + Maybe value -> + CellPatch value +cellFromEndpoints before after = + case (before, after) of + (Nothing, Nothing) -> + AssertAbsent + (Nothing, Just value) -> + Insert value + (Just value, Nothing) -> + Delete value + (Just beforeValue, Just afterValue) -> + Replace beforeValue afterValue +{-# INLINE cellFromEndpoints #-} + +mapCell :: + (value -> value') -> + CellPatch value -> + CellPatch value' +mapCell project = + matchCell + AssertAbsent + (Insert . project) + (Delete . project) + (\before after -> Replace (project before) (project after)) +{-# INLINE mapCell #-} + +traverseCell :: + Applicative effect => + (value -> effect value') -> + CellPatch value -> + effect (CellPatch value') +traverseCell project cell = + case cell of + AssertAbsent -> + pure AssertAbsent + Insert value -> + Insert <$> project value + Delete value -> + Delete <$> project value + Replace before after -> + Replace <$> project before <*> project after +{-# INLINE traverseCell #-} diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Compose/Aligned.hs b/src-patch/Moonlight/Delta/Patch/Internal/Compose/Aligned.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Compose/Aligned.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Moonlight.Delta.Patch.Internal.Compose.Aligned + ( tryAlignedTree, + tryAlignedPage, + ) +where + +import Data.Map.Internal qualified as MapInternal +import Data.Map.Strict qualified as Map +import Moonlight.Delta.Patch.Internal.Cell + ( endpointToMaybe, + ) +import Moonlight.Delta.Patch.Internal.Page +import Moonlight.Delta.Patch.Internal.Types +import Prelude + +tryAlignedTree :: + forall key value error. + (Ord key, Eq value) => + (key -> Maybe value -> Maybe value -> error) -> + Map.Map key (Page key value) -> + Map.Map key (Page key value) -> + Either error (Maybe (Map.Map key (Page key value))) +tryAlignedTree makeBoundaryError = + go + where + go MapInternal.Tip MapInternal.Tip = + Right (Just MapInternal.Tip) + go + (MapInternal.Bin olderSize olderMaximum olderPage olderLeft olderRight) + (MapInternal.Bin newerSize newerMaximum newerPage newerLeft newerRight) + | olderSize /= newerSize = + Right Nothing + | compare olderMaximum newerMaximum /= EQ = + Right Nothing + | otherwise = do + maybeLeft <- go olderLeft newerLeft + case maybeLeft of + Nothing -> + Right Nothing + Just resultLeft -> do + maybePage <- tryAlignedPage makeBoundaryError olderMaximum olderPage newerMaximum newerPage + case maybePage of + Nothing -> + Right Nothing + Just (_, resultPage) -> do + maybeRight <- go olderRight newerRight + pure + ( fmap + (\resultRight -> MapInternal.Bin newerSize newerMaximum resultPage resultLeft resultRight) + maybeRight + ) + go _ _ = + Right Nothing +{-# INLINABLE tryAlignedTree #-} + +tryAlignedPage :: + forall key value error. + (Ord key, Eq value) => + (key -> Maybe value -> Maybe value -> error) -> + key -> + Page key value -> + key -> + Page key value -> + Either error (Maybe (key, Page key value)) +tryAlignedPage makeBoundaryError olderMaximum olderPage newerMaximum newerPage = + case + validateAlignedPageBoundary + pageBoundaryError + olderMaximum + olderPage + (pageAfterColumn olderPage) + newerMaximum + newerPage + (pageBeforeColumn newerPage) + of + PageBoundaryMatched -> + Right + ( Just + ( newerMaximum, + newerPage {pageBeforeColumn = pageBeforeColumn olderPage} + ) + ) + PageBoundaryDiverged -> + Right Nothing + PageBoundaryRejected failure -> + Left failure + where + pageBoundaryError key olderAfter newerBefore = + makeBoundaryError key (endpointToMaybe olderAfter) (endpointToMaybe newerBefore) +{-# INLINABLE tryAlignedPage #-} diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Compose/Core.hs b/src-patch/Moonlight/Delta/Patch/Internal/Compose/Core.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Compose/Core.hs @@ -0,0 +1,580 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- Loop-local rebinding (state/cursor/coverage) is the engine idiom here; shadowing is deliberate. +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Moonlight.Delta.Patch.Internal.Compose.Core + ( compose, + ComposeResult (..), + Coverage (..), + NewKeyPolicy (..), + composeWith, + ) +where + +import Control.Monad.ST (ST, runST) +import Data.Bits (testBit) +import Data.Map.Strict qualified as Map +import Data.Primitive.SmallArray + ( SmallArray, + indexSmallArray, + sizeofSmallArray, + ) +import Moonlight.Delta.Patch.Internal.Builder +import Moonlight.Delta.Patch.Internal.Cell + ( cellAfterEndpoint, + cellBeforeEndpoint, + cellFromEndpointPair, + endpointToMaybe, + ) +import Moonlight.Delta.Patch.Internal.Compose.Aligned +import Moonlight.Delta.Patch.Internal.Compose.Range +import Moonlight.Delta.Patch.Internal.Construction + ( fromAscList, + ) +import Moonlight.Delta.Patch.Internal.Cursor +import Moonlight.Delta.Patch.Internal.Page +import Moonlight.Delta.Patch.Internal.Types +import Prelude hiding (null) + +composeBoundaryError :: key -> Maybe value -> Maybe value -> ComposeError key value +composeBoundaryError key olderAfter newerBefore = + ComposeBoundaryMismatch + { boundaryKey = key, + olderAfter = olderAfter, + newerBefore = newerBefore + } +{-# INLINE composeBoundaryError #-} + +data Coverage = Coverage + { coverageOlderOnly :: !Bool, + coverageNewerOnly :: !Bool + } + +emptyCoverage :: Coverage +emptyCoverage = + Coverage + { coverageOlderOnly = False, + coverageNewerOnly = False + } +{-# INLINE emptyCoverage #-} + +markOlderOnly :: Coverage -> Coverage +markOlderOnly coverage = + coverage {coverageOlderOnly = True} +{-# INLINE markOlderOnly #-} + +markNewerOnly :: Coverage -> Coverage +markNewerOnly coverage = + coverage {coverageNewerOnly = True} +{-# INLINE markNewerOnly #-} + +combineCoverage :: Coverage -> Coverage -> Coverage +combineCoverage left right = + Coverage + { coverageOlderOnly = coverageOlderOnly left || coverageOlderOnly right, + coverageNewerOnly = coverageNewerOnly left || coverageNewerOnly right + } +{-# INLINE combineCoverage #-} + +data NewKeyPolicy state key value error + = IgnoreNewKeys + | CheckNewKeys !(state -> key -> Maybe value -> Either error state) + +data ComposeResult state key value = ComposeResult + { patch :: !(Patch key value), + state :: !state, + coverage :: !Coverage + } + +compose :: + forall key value. + (PatchKey key, PatchValue value) => + Patch key value -> + Patch key value -> + Either (ComposeError key value) (Patch key value) +compose newer older = + fmap normalize (composeCanonical newer older) +{-# INLINABLE compose #-} + +composeCanonical :: + forall key value. + (PatchKey key, PatchValue value) => + Patch key value -> + Patch key value -> + Either (ComposeError key value) (Patch key value) +composeCanonical newer older + | null newer = + Right older + | null older = + Right newer + | SmallPatch olderCells <- older, + SmallPatch newerCells <- newer = + composeSmallSmall olderCells newerCells + | otherwise = + let !olderPaged = toPaged older + !newerPaged = toPaged newer + in case disjointComposition olderPaged newerPaged of + Just result -> + Right result + Nothing -> do + ComposeResult {patch} <- + composeWith IgnoreNewKeys () composeBoundaryError olderPaged newerPaged + pure patch +{-# INLINABLE composeCanonical #-} + +composeSmallSmall :: + (PatchKey key, PatchValue value) => + SmallArray (Cell key value) -> + SmallArray (Cell key value) -> + Either (ComposeError key value) (Patch key value) +composeSmallSmall olderCells newerCells = + fmap fromAscList (mergeSmallCells olderCells newerCells) +{-# INLINABLE composeSmallSmall #-} + +mergeSmallCells :: + forall key value. + (Ord key, Eq value) => + SmallArray (Cell key value) -> + SmallArray (Cell key value) -> + Either (ComposeError key value) [(key, CellPatch value)] +mergeSmallCells olderCells newerCells = + go 0 0 + where + !olderLength = sizeofSmallArray olderCells + !newerLength = sizeofSmallArray newerCells + + go :: Int -> Int -> Either (ComposeError key value) [(key, CellPatch value)] + go !olderIndex !newerIndex + | olderIndex == olderLength && newerIndex == newerLength = + Right [] + | olderIndex == olderLength = + case indexSmallArray newerCells newerIndex of + Cell key cell -> + fmap ((key, cell) :) (go olderIndex (newerIndex + 1)) + | newerIndex == newerLength = + case indexSmallArray olderCells olderIndex of + Cell key cell -> + fmap ((key, cell) :) (go (olderIndex + 1) newerIndex) + | otherwise = + case (indexSmallArray olderCells olderIndex, indexSmallArray newerCells newerIndex) of + (Cell olderKey olderCell, Cell newerKey newerCell) -> + case compare olderKey newerKey of + LT -> + fmap ((olderKey, olderCell) :) (go (olderIndex + 1) newerIndex) + GT -> + fmap ((newerKey, newerCell) :) (go olderIndex (newerIndex + 1)) + EQ -> + let !olderAfter = cellAfterEndpoint olderCell + !newerBefore = cellBeforeEndpoint newerCell + in if olderAfter /= newerBefore + then + Left + ( composeBoundaryError + olderKey + (endpointToMaybe olderAfter) + (endpointToMaybe newerBefore) + ) + else + let !combined = + cellFromEndpointPair + (cellBeforeEndpoint olderCell) + (cellAfterEndpoint newerCell) + in fmap ((newerKey, combined) :) (go (olderIndex + 1) (newerIndex + 1)) +{-# INLINABLE mergeSmallCells #-} + +composeWith :: + forall state key value error. + (PatchKey key, PatchValue value) => + NewKeyPolicy state key value error -> + state -> + (key -> Maybe value -> Maybe value -> error) -> + Patch key value -> + Patch key value -> + Either error (ComposeResult state key value) +composeWith newKeyPolicy initialState makeBoundaryError olderInput newerInput + | Just patch <- disjointComposition older newer = do + nextState <- checkNewPatch newKeyPolicy initialState newer + Right + ComposeResult + { patch = patch, + state = nextState, + coverage = + Coverage + { coverageOlderOnly = True, + coverageNewerOnly = True + } + } + | Just rangewise <- composeOverlappingRanges newKeyPolicy initialState makeBoundaryError older newer = + rangewise + | otherwise = + case tryAlignedTree makeBoundaryError (pagesOf older) (pagesOf newer) of + Left failure -> + Left failure + Right (Just pages) -> + Right + ComposeResult + { patch = + PagedPatch (entryCount older) pages, + state = initialState, + coverage = emptyCoverage + } + Right Nothing -> + composePagewise newKeyPolicy initialState makeBoundaryError older newer + where + older = toPaged olderInput + newer = toPaged newerInput +{-# INLINABLE composeWith #-} + +composeOverlappingRanges :: + forall state key value error. + (PatchKey key, PatchValue value) => + NewKeyPolicy state key value error -> + state -> + (key -> Maybe value -> Maybe value -> error) -> + Patch key value -> + Patch key value -> + Maybe (Either error (ComposeResult state key value)) +composeOverlappingRanges policy initialState makeBoundaryError older newer = + case (patchBounds older, patchBounds newer) of + (Just (olderMinimum, olderMaximum), Just (newerMinimum, newerMaximum)) -> + let !overlapMinimum = max olderMinimum newerMinimum + !overlapMaximum = min olderMaximum newerMaximum + !hasExterior = + olderMinimum < overlapMinimum + || newerMinimum < overlapMinimum + || olderMaximum > overlapMaximum + || newerMaximum > overlapMaximum + in if hasExterior + then + Just $ do + let (!olderBefore, !olderMiddle, !olderAfter) = + splitPatchRange overlapMinimum overlapMaximum older + (!newerBefore, !newerMiddle, !newerAfter) = + splitPatchRange overlapMinimum overlapMaximum newer + beforeResult <- composeWith policy initialState makeBoundaryError olderBefore newerBefore + middleResult <- + composeWith + policy + (state beforeResult) + makeBoundaryError + olderMiddle + newerMiddle + afterResult <- + composeWith + policy + (state middleResult) + makeBoundaryError + olderAfter + newerAfter + Right + ComposeResult + { patch = + appendPatch + (patch beforeResult) + ( appendPatch + (patch middleResult) + (patch afterResult) + ), + state = state afterResult, + coverage = + combineCoverage + (coverage beforeResult) + ( combineCoverage + (coverage middleResult) + (coverage afterResult) + ) + } + else Nothing + _ -> + Nothing +{-# INLINABLE composeOverlappingRanges #-} + +patchBounds :: Patch key value -> Maybe (key, key) +patchBounds patch = + (,) <$> minimumKey patch <*> maximumKey patch +{-# INLINE patchBounds #-} + +checkNewPatch :: + NewKeyPolicy state key value error -> + state -> + Patch key value -> + Either error state +checkNewPatch policy initialState patch = + go initialState (ascCursor (pagesOf patch)) + where + go !state AscEnd = + Right state + go !state cursor@(AscCursor maximumKey page _ _) = do + nextState <- checkNewPage policy state maximumKey page + go nextState (ascAdvance cursor) +{-# INLINABLE checkNewPatch #-} + +composePagewise :: + forall state key value error. + (PatchKey key, PatchValue value) => + NewKeyPolicy state key value error -> + state -> + (key -> Maybe value -> Maybe value -> error) -> + Patch key value -> + Patch key value -> + Either error (ComposeResult state key value) +composePagewise policy initialState makeBoundaryError older newer = + go initialState 0 emptyCoverage [] (ascCursor (pagesOf older)) (ascCursor (pagesOf newer)) + where + go !state !entryCount !coverage !pagesReverse AscEnd AscEnd = + Right + ComposeResult + { patch = + PagedPatch entryCount (Map.fromDistinctAscList (reverse pagesReverse)), + state = state, + coverage = coverage + } + go !state !entryCount !coverage !pagesReverse olderCursor AscEnd = + drainOlder state entryCount coverage pagesReverse olderCursor + go !state !entryCount !coverage !pagesReverse AscEnd newerCursor = + drainNewer state entryCount coverage pagesReverse newerCursor + go !state !entryCount !coverage !pagesReverse olderCursor@(AscCursor olderMaximum olderPage _ _) newerCursor@(AscCursor newerMaximum newerPage _ _) = + case compare olderMaximum newerMaximum of + EQ -> + case tryAlignedPage makeBoundaryError olderMaximum olderPage newerMaximum newerPage of + Left failure -> + Left failure + Right (Just outputPage) -> + go + state + (entryCount + pageCount newerPage) + coverage + (outputPage : pagesReverse) + (ascAdvance olderCursor) + (ascAdvance newerCursor) + Right Nothing -> + composeRowsFrom policy state makeBoundaryError entryCount coverage pagesReverse olderCursor newerCursor + LT + | olderMaximum < pageMinimumKey newerMaximum newerPage -> + go + state + (entryCount + pageCount olderPage) + (markOlderOnly coverage) + ((olderMaximum, olderPage) : pagesReverse) + (ascAdvance olderCursor) + newerCursor + GT + | newerMaximum < pageMinimumKey olderMaximum olderPage -> do + nextState <- checkNewPage policy state newerMaximum newerPage + go + nextState + (entryCount + pageCount newerPage) + (markNewerOnly coverage) + ((newerMaximum, newerPage) : pagesReverse) + olderCursor + (ascAdvance newerCursor) + _ -> + composeRowsFrom policy state makeBoundaryError entryCount coverage pagesReverse olderCursor newerCursor + + drainOlder !state !entryCount !coverage !pagesReverse cursor = + case cursor of + AscEnd -> + go state entryCount coverage pagesReverse AscEnd AscEnd + AscCursor maximumKey page _ _ -> + drainOlder + state + (entryCount + pageCount page) + (markOlderOnly coverage) + ((maximumKey, page) : pagesReverse) + (ascAdvance cursor) + + drainNewer !state !entryCount !coverage !pagesReverse cursor = + case cursor of + AscEnd -> + go state entryCount coverage pagesReverse AscEnd AscEnd + AscCursor maximumKey page _ _ -> do + nextState <- checkNewPage policy state maximumKey page + drainNewer + nextState + (entryCount + pageCount page) + (markNewerOnly coverage) + ((maximumKey, page) : pagesReverse) + (ascAdvance cursor) +{-# INLINABLE composePagewise #-} + +checkNewPage :: NewKeyPolicy state key value error -> state -> key -> Page key value -> Either error state +checkNewPage IgnoreNewKeys state _ _ = + Right state +checkNewPage (CheckNewKeys check) initialState maximumKey page = + case columnView (pageCount page) (pageBeforeColumn page) of + ColumnView mask values -> + go initialState 0 0 mask values + where + go !state !logicalIndex !packedIndex !mask !values + | logicalIndex == pageCount page = + Right state + | otherwise = + let !present = testBit mask logicalIndex + !before = + if present + then Just (valueColumnAt values packedIndex) + else Nothing + !key = pageKeyAt maximumKey page logicalIndex + in case check state key before of + Left failure -> + Left failure + Right nextState -> + go + nextState + (logicalIndex + 1) + (if present then packedIndex + 1 else packedIndex) + mask + values +{-# INLINABLE checkNewPage #-} + +composeRowsFrom :: + forall state key value error. + (PatchKey key, PatchValue value) => + NewKeyPolicy state key value error -> + state -> + (key -> Maybe value -> Maybe value -> error) -> + Int -> + Coverage -> + [(key, Page key value)] -> + AscCursor key (Page key value) -> + AscCursor key (Page key value) -> + Either error (ComposeResult state key value) +composeRowsFrom policy initialState makeBoundaryError prefixEntryCount initialCoverage prefixPagesReverse olderPages newerPages = + runST $ do + builder <- newBuilder + let (!keptEntryCount, !keptPagesReverse, !seedPage) = + case prefixPagesReverse of + [] -> (prefixEntryCount, [], Nothing) + page@(_, patchPage) : remaining -> (prefixEntryCount - pageCount patchPage, remaining, Just page) + case seedPage of + Nothing -> pure () + Just (maximumKey, page) -> appendPageCopy builder maximumKey page + merged <- + mergeRows + policy + makeBoundaryError + builder + initialState + initialCoverage + (fromAsc olderPages) + (fromAsc newerPages) + case merged of + Left failure -> + pure (Left failure) + Right (finalState, finalCoverage) -> do + tailPatch <- finishBuilder builder + let !prefixMap = Map.fromDistinctAscList (reverse keptPagesReverse) + !resultPages = appendPages prefixMap (pagesOf tailPatch) + pure + ( Right + ComposeResult + { patch = + PagedPatch (keptEntryCount + entryCount tailPatch) resultPages, + state = finalState, + coverage = finalCoverage + } + ) +{-# INLINABLE composeRowsFrom #-} + +mergeRows :: + forall state key value error s. + (PatchKey key, PatchValue value) => + NewKeyPolicy state key value error -> + (key -> Maybe value -> Maybe value -> error) -> + Builder s key value -> + state -> + Coverage -> + Cursor key value -> + Cursor key value -> + ST s (Either error (state, Coverage)) +mergeRows policy makeBoundaryError builder = + go + where + go !state !coverage CursorEnd CursorEnd = + pure (Right (state, coverage)) + go !state !coverage olderCursor CursorEnd = do + copyOlderTail olderCursor + pure (Right (state, markOlderOnly coverage)) + go !state !coverage CursorEnd newerCursor = + copyNewerTail state coverage newerCursor + go !state !coverage olderCursor newerCursor + | Just (olderMaximum, olderPage) <- cursorPageStart olderCursor, + Just (newerMaximum, newerPage) <- cursorPageStart newerCursor = + case compare olderMaximum newerMaximum of + EQ -> + case tryAlignedPage makeBoundaryError olderMaximum olderPage newerMaximum newerPage of + Left failure -> + pure (Left failure) + Right (Just (resultMaximum, resultPage)) -> do + appendPageCopy builder resultMaximum resultPage + go state coverage (advancePage olderCursor) (advancePage newerCursor) + Right Nothing -> + mergeCurrentRows state coverage olderCursor newerCursor + LT + | olderMaximum < pageMinimumKey newerMaximum newerPage -> do + appendPageCopy builder olderMaximum olderPage + go state (markOlderOnly coverage) (advancePage olderCursor) newerCursor + GT + | newerMaximum < pageMinimumKey olderMaximum olderPage -> + case checkNewPage policy state newerMaximum newerPage of + Left failure -> pure (Left failure) + Right nextState -> do + appendPageCopy builder newerMaximum newerPage + go nextState (markNewerOnly coverage) olderCursor (advancePage newerCursor) + _ -> + mergeCurrentRows state coverage olderCursor newerCursor + | otherwise = + mergeCurrentRows state coverage olderCursor newerCursor + + mergeCurrentRows !state !coverage olderCursor newerCursor = + case (currentRow olderCursor, currentRow newerCursor) of + (Just (olderKey, olderBefore, olderAfter), Just (newerKey, newerBefore, newerAfter)) -> + case compare olderKey newerKey of + LT -> do + appendTransition builder olderKey olderBefore olderAfter + go state (markOlderOnly coverage) (advanceRow olderCursor) newerCursor + GT -> + case checkNewRow policy state newerKey (endpointToMaybe newerBefore) of + Left failure -> pure (Left failure) + Right nextState -> do + appendTransition builder newerKey newerBefore newerAfter + go nextState (markNewerOnly coverage) olderCursor (advanceRow newerCursor) + EQ -> + if olderAfter /= newerBefore + then pure (Left (makeBoundaryError newerKey (endpointToMaybe olderAfter) (endpointToMaybe newerBefore))) + else do + appendTransition builder newerKey olderBefore newerAfter + go state coverage (advanceRow olderCursor) (advanceRow newerCursor) + _ -> + pure (Right (state, coverage)) + + copyOlderTail CursorEnd = + pure () + copyOlderTail cursor = + case currentRow cursor of + Just (key, before, after) -> do + appendTransition builder key before after + copyOlderTail (advanceRow cursor) + Nothing -> pure () + + copyNewerTail !state !coverage CursorEnd = + pure (Right (state, coverage)) + copyNewerTail !state !coverage cursor = + case currentRow cursor of + Just (key, before, after) -> + case checkNewRow policy state key (endpointToMaybe before) of + Left failure -> pure (Left failure) + Right nextState -> do + appendTransition builder key before after + copyNewerTail nextState (markNewerOnly coverage) (advanceRow cursor) + Nothing -> pure (Right (state, coverage)) +{-# INLINABLE mergeRows #-} + +checkNewRow :: NewKeyPolicy state key value error -> state -> key -> Maybe value -> Either error state +checkNewRow IgnoreNewKeys state _ _ = + Right state +checkNewRow (CheckNewKeys check) state key before = + check state key before +{-# INLINE checkNewRow #-} diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Compose/Range.hs b/src-patch/Moonlight/Delta/Patch/Internal/Compose/Range.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Compose/Range.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- Loop-local rebinding (state/cursor/coverage) is the engine idiom here; shadowing is deliberate. +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Moonlight.Delta.Patch.Internal.Compose.Range + ( disjointComposition, + splitPatchRange, + appendPatch, + appendPages, + pageToAscCells, + ) +where + +import Control.Monad.ST (ST, runST) +import Data.Map.Internal qualified as MapInternal +import Data.Map.Strict qualified as Map +import Moonlight.Delta.Patch.Internal.Builder +import Moonlight.Delta.Patch.Internal.Cell + ( cellAfterEndpoint, + cellBeforeEndpoint, + ) +import Moonlight.Delta.Patch.Internal.Page +import Moonlight.Delta.Patch.Internal.Types +import Prelude + +disjointComposition :: Ord key => Patch key value -> Patch key value -> Maybe (Patch key value) +disjointComposition + (PagedPatch olderCount olderPages) + (PagedPatch newerCount newerPages) = + case (Map.lookupMax olderPages, Map.lookupMin newerPages) of + (Just (olderMaximum, _), Just (newerMaximum, newerFirstPage)) + | olderMaximum < pageMinimumKey newerMaximum newerFirstPage -> + Just (PagedPatch (olderCount + newerCount) (MapInternal.link2 olderPages newerPages)) + _ -> + case (Map.lookupMax newerPages, Map.lookupMin olderPages) of + (Just (newerMaximum, _), Just (olderMaximum, olderFirstPage)) + | newerMaximum < pageMinimumKey olderMaximum olderFirstPage -> + Just (PagedPatch (olderCount + newerCount) (MapInternal.link2 newerPages olderPages)) + _ -> Nothing +disjointComposition _ _ = + Nothing +{-# INLINABLE disjointComposition #-} + +splitPatchRange :: + (PatchKey key, PatchValue value) => + key -> + key -> + Patch key value -> + (Patch key value, Patch key value, Patch key value) +splitPatchRange minimumKey maximumKey patch = + let (!beforePages, !atOrAfterMinimum) = + splitPagesLessThan minimumKey (pagesOf patch) + (!middlePages, !afterPages) = + splitPagesLessOrEqual maximumKey atOrAfterMinimum + in (patchFromPages beforePages, patchFromPages middlePages, patchFromPages afterPages) +{-# INLINABLE splitPatchRange #-} + +patchFromPages :: Map.Map key (Page key value) -> Patch key value +patchFromPages pages = + PagedPatch (pageMapEntryCount pages) pages +{-# INLINE patchFromPages #-} + +pageMapEntryCount :: Map.Map key (Page key value) -> Int +pageMapEntryCount = + Map.foldlWithKey' (\count _ page -> count + pageCount page) 0 +{-# INLINE pageMapEntryCount #-} + +appendPatch :: Patch key value -> Patch key value -> Patch key value +appendPatch left right = + PagedPatch + (entryCount left + entryCount right) + (appendPages (pagesOf left) (pagesOf right)) +{-# INLINE appendPatch #-} + +appendPages :: Map.Map key value -> Map.Map key value -> Map.Map key value +appendPages left right = + case (left, right) of + (MapInternal.Tip, _) -> + right + (_, MapInternal.Tip) -> + left + _ -> + MapInternal.link2 left right +{-# INLINE appendPages #-} + +splitPagesLessThan :: + (PatchKey key, PatchValue value) => + key -> + Map.Map key (Page key value) -> + (Map.Map key (Page key value), Map.Map key (Page key value)) +splitPagesLessThan target pages = + case pageForKey target pages of + Nothing -> + (pages, Map.empty) + Just (maximumKey, page) -> + let (!beforePages, !_found, !afterPages) = + Map.splitLookup maximumKey pages + !minimumKey = + pageMinimumKey maximumKey page + in if target <= minimumKey + then (beforePages, appendPages (Map.singleton maximumKey page) afterPages) + else + let !splitIndex = + pageLowerBound target maximumKey page + !beforeSlice = + pageSlicePages maximumKey page 0 splitIndex + !afterSlice = + pageSlicePages maximumKey page splitIndex (pageCount page - splitIndex) + in ( appendPages beforePages beforeSlice, + appendPages afterSlice afterPages + ) +{-# INLINABLE splitPagesLessThan #-} + +splitPagesLessOrEqual :: + (PatchKey key, PatchValue value) => + key -> + Map.Map key (Page key value) -> + (Map.Map key (Page key value), Map.Map key (Page key value)) +splitPagesLessOrEqual target pages = + case pageForKey target pages of + Nothing -> + (pages, Map.empty) + Just (maximumKey, page) -> + let (!beforePages, !_found, !afterPages) = + Map.splitLookup maximumKey pages + !minimumKey = + pageMinimumKey maximumKey page + in if target < minimumKey + then (beforePages, appendPages (Map.singleton maximumKey page) afterPages) + else + if maximumKey <= target + then (appendPages beforePages (Map.singleton maximumKey page), afterPages) + else + let !splitIndex = + pageUpperBound target maximumKey page + !beforeSlice = + pageSlicePages maximumKey page 0 splitIndex + !afterSlice = + pageSlicePages maximumKey page splitIndex (pageCount page - splitIndex) + in ( appendPages beforePages beforeSlice, + appendPages afterSlice afterPages + ) +{-# INLINABLE splitPagesLessOrEqual #-} + + +pageLowerBound :: Ord key => key -> key -> Page key value -> Int +pageLowerBound target maximumKey page = + search 0 (pageCount page) + where + search !low !high + | low == high = + low + | otherwise = + let !middle = (low + high) `quot` 2 + !middleKey = pageKeyAt maximumKey page middle + in case compare middleKey target of + LT -> search (middle + 1) high + EQ -> middle + GT -> search low middle +{-# INLINABLE pageLowerBound #-} + +pageUpperBound :: Ord key => key -> key -> Page key value -> Int +pageUpperBound target maximumKey page = + search 0 (pageCount page) + where + search !low !high + | low == high = + low + | otherwise = + let !middle = (low + high) `quot` 2 + !middleKey = pageKeyAt maximumKey page middle + in case compare middleKey target of + GT -> search low middle + _ -> search (middle + 1) high +{-# INLINABLE pageUpperBound #-} + +pageSlicePages :: + forall key value. + (PatchKey key, PatchValue value) => + key -> + Page key value -> + Int -> + Int -> + Map.Map key (Page key value) +pageSlicePages maximumKey page !start !sliceLength + | sliceLength <= 0 = + Map.empty + | start <= 0 && sliceLength == pageCount page = + Map.singleton maximumKey page + | otherwise = + pagesOf $ + runST $ do + builder <- newBuilder + appendSliceRows builder 0 + finishBuilder builder + where + appendSliceRows :: Builder s key value -> Int -> ST s () + appendSliceRows builder !offset + | offset == sliceLength = + pure () + | otherwise = do + let !rowIndex = start + offset + !cell = rowCellAt page rowIndex + appendTransition + builder + (pageKeyAt maximumKey page rowIndex) + (cellBeforeEndpoint cell) + (cellAfterEndpoint cell) + appendSliceRows builder (offset + 1) +{-# INLINABLE pageSlicePages #-} + +pageToAscCells :: key -> Page key value -> [(key, CellPatch value)] +pageToAscCells maximumKey page = + fmap + (\index -> (pageKeyAt maximumKey page index, rowCellAt page index)) + [0 .. pageCount page - 1] +{-# INLINE pageToAscCells #-} diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Compose/Record.hs b/src-patch/Moonlight/Delta/Patch/Internal/Compose/Record.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Compose/Record.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- Loop-local rebinding (state/cursor/coverage) is the engine idiom here; shadowing is deliberate. +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Moonlight.Delta.Patch.Internal.Compose.Record + ( recordApplied, + recordMany, + ) +where + +import Data.Foldable qualified as Foldable +import Data.Map.Strict qualified as Map +import Moonlight.Delta.Patch.Internal.Builder + ( toPagedMap, + ) +import Moonlight.Delta.Patch.Internal.Cell + ( cellAfterEndpoint, + cellBeforeEndpoint, + cellFromEndpointPair, + endpointToMaybe, + ) +import Moonlight.Delta.Patch.Internal.Compose.Range +import Moonlight.Delta.Patch.Internal.Construction + ( fromAscList, + singleton, + ) +import Moonlight.Delta.Patch.Internal.Page +import Moonlight.Delta.Patch.Internal.Types +import Prelude + +data InsertCellResult key value = InsertCellResult !Bool ![(key, CellPatch value)] + +recordApplied :: + forall key value. + (PatchKey key, PatchValue value) => + key -> + CellPatch value -> + Patch key value -> + Either (ComposeError key value) (Patch key value) +recordApplied key latest patch = + case patch of + SmallPatch cells -> + fmap fromAscList (insertOrReplaceSmall (smallCellsToAscList cells)) + PagedPatch entryCount pages -> + case pageForInsertion key pages of + Nothing -> + Right (singleton key latest) + Just (maximumKey, page) -> + case pageLookupIndex key maximumKey page of + Just rowIndex -> + replaceRecordedRow entryCount pages maximumKey page rowIndex + Nothing -> + Right (insertRecordedRow entryCount pages maximumKey page) + where + !latestBefore = cellBeforeEndpoint latest + !latestAfter = cellAfterEndpoint latest + + insertOrReplaceSmall [] = + Right [(key, latest)] + insertOrReplaceSmall (row@(rowKey, rowCell) : rest) = + case compare key rowKey of + LT -> + Right ((key, latest) : row : rest) + EQ -> + let !olderAfter = cellAfterEndpoint rowCell + in if olderAfter /= latestBefore + then + Left + ComposeBoundaryMismatch + { boundaryKey = key, + olderAfter = endpointToMaybe olderAfter, + newerBefore = endpointToMaybe latestBefore + } + else + let !combined = cellFromEndpointPair (cellBeforeEndpoint rowCell) latestAfter + in Right ((key, combined) : rest) + GT -> + fmap (row :) (insertOrReplaceSmall rest) + + replaceRecordedRow entryCount pages maximumKey page rowIndex = + let !olderAfter = cellAfterEndpoint (rowCellAt page rowIndex) + in if olderAfter /= latestBefore + then + Left + ComposeBoundaryMismatch + { boundaryKey = key, + olderAfter = endpointToMaybe olderAfter, + newerBefore = endpointToMaybe latestBefore + } + else + let (!updatedMaximum, !updatedPage) = + replacePageEntryAfter key latestAfter rowIndex maximumKey page + in Right + (PagedPatch entryCount (replaceRecordedPage maximumKey updatedMaximum updatedPage pages)) + + insertRecordedRow entryCount pages maximumKey page = + let InsertCellResult inserted localRows = + insertCell (pageToAscCells maximumKey page) + !localPatch = + fromAscList localRows + (!leftPages, !_removedPage, !rightPages) = + Map.splitLookup maximumKey pages + in PagedPatch + ( entryCount + + if inserted + then 1 + else 0 + ) + (appendPages leftPages (appendPages (toPagedMap localPatch) rightPages)) + + insertCell rows = + case rows of + [] -> + InsertCellResult True [(key, latest)] + row@(rowKey, _rowCell) : rest -> + case compare key rowKey of + LT -> + InsertCellResult True ((key, latest) : rows) + EQ -> + InsertCellResult False ((key, latest) : rest) + GT -> + let InsertCellResult inserted insertedRows = insertCell rest + in InsertCellResult inserted (row : insertedRows) +{-# INLINABLE recordApplied #-} + +recordMany :: + forall edits key value. + (Foldable edits, PatchKey key, PatchValue value) => + edits (key, CellPatch value) -> + Either (ComposeError key value) (Patch key value) +recordMany edits = + fmap temporalRowsToPatch (Foldable.foldlM recordOne Map.empty edits) + where + recordOne :: + Map.Map key (Endpoint value, Endpoint value) -> + (key, CellPatch value) -> + Either (ComposeError key value) (Map.Map key (Endpoint value, Endpoint value)) + recordOne accumulated (key, patch) = + let !before = cellBeforeEndpoint patch + !after = cellAfterEndpoint patch + in case Map.lookup key accumulated of + Nothing -> + Right (Map.insert key (before, after) accumulated) + Just (initial, current) + | current == before -> + Right (Map.insert key (initial, after) accumulated) + | otherwise -> + Left + ComposeBoundaryMismatch + { boundaryKey = key, + olderAfter = endpointToMaybe current, + newerBefore = endpointToMaybe before + } + + temporalRowsToPatch :: + Map.Map key (Endpoint value, Endpoint value) -> + Patch key value + temporalRowsToPatch = + fromAscList + . fmap + ( \(key, (initial, current)) -> + (key, cellFromEndpointPair initial current) + ) + . Map.toAscList +{-# INLINABLE recordMany #-} diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Compose/SameSupport.hs b/src-patch/Moonlight/Delta/Patch/Internal/Compose/SameSupport.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Compose/SameSupport.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Moonlight.Delta.Patch.Internal.Compose.SameSupport + ( SameSupport, + reflexiveSupport, + extendSameSupport, + sameSupportLatest, + validateBoundarySameSupport, + spliceSameSupport, + ) +where + +import Control.Monad.ST (ST, runST) +import Moonlight.Delta.Patch.Internal.Builder +import Moonlight.Delta.Patch.Internal.Cell + ( cellAfterEndpoint, + cellBeforeEndpoint, + endpointToMaybe, + ) +import Moonlight.Delta.Patch.Internal.Cursor +import Moonlight.Delta.Patch.Internal.Types +import Prelude + +data SameSupport key value = SameSupport !(Patch key value) !(Patch key value) + +reflexiveSupport :: Patch key value -> SameSupport key value +reflexiveSupport patch = + SameSupport patch patch +{-# INLINE reflexiveSupport #-} + +sameSupportLatest :: SameSupport key value -> Patch key value +sameSupportLatest (SameSupport _ latest) = + latest +{-# INLINE sameSupportLatest #-} + +extendSameSupport :: SameSupport key value -> SameSupport key value -> SameSupport key value +extendSameSupport (SameSupport first _) (SameSupport _ latest) = + SameSupport first latest +{-# INLINE extendSameSupport #-} + +validateBoundarySameSupport :: + forall key value error. + (Ord key, Eq value) => + (key -> Maybe value -> Maybe value -> error) -> + Patch key value -> + Patch key value -> + Either error (Maybe (SameSupport key value)) +validateBoundarySameSupport makeBoundaryError older newer + | entryCount older /= entryCount newer = + Right Nothing + | otherwise = + go (cellsForInstance older) (cellsForInstance newer) + where + go [] [] = + Right (Just (SameSupport older newer)) + go [] _ = + Right Nothing + go _ [] = + Right Nothing + go ((olderKey, olderCell) : olderRest) ((newerKey, newerCell) : newerRest) = + case compare olderKey newerKey of + LT -> Right Nothing + GT -> Right Nothing + EQ -> + let !olderAfter = endpointToMaybe (cellAfterEndpoint olderCell) + !newerBefore = endpointToMaybe (cellBeforeEndpoint newerCell) + in if olderAfter /= newerBefore + then Left (makeBoundaryError newerKey olderAfter newerBefore) + else go olderRest newerRest +{-# INLINABLE validateBoundarySameSupport #-} + +spliceSameSupport :: (PatchKey key, PatchValue value) => SameSupport key value -> Patch key value +spliceSameSupport (SameSupport first latest) = + runST $ do + builder <- newBuilder + zipRows builder (cursor (toPagedMap first)) (cursor (toPagedMap latest)) + finishBuilder builder + where + zipRows :: (PatchKey key, PatchValue value) => Builder s key value -> Cursor key value -> Cursor key value -> ST s () + zipRows _ CursorEnd CursorEnd = + pure () + zipRows builder firstCursor latestCursor = + case (currentRow firstCursor, currentRow latestCursor) of + (Just (_firstKey, before, _firstAfter), Just (latestKey, _latestBefore, after)) -> do + appendTransition builder latestKey before after + zipRows builder (advanceRow firstCursor) (advanceRow latestCursor) + _ -> pure () +{-# INLINABLE spliceSameSupport #-} + diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Construction.hs b/src-patch/Moonlight/Delta/Patch/Internal/Construction.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Construction.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- Loop-local rebinding (state/cursor/coverage) is the engine idiom here; shadowing is deliberate. +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Moonlight.Delta.Patch.Internal.Construction + ( empty, + singleton, + fromList, + fromAscList, + toAscList, + lookup, + mapMaybeWithKey, + foldWithKey, + foldWithKey', + traverseWithKey, + invert, + diff, + ) +where + +import Control.Monad.ST (ST, runST) +import Data.Bits (testBit) +import Data.Foldable (traverse_) +import Data.Map.Internal qualified as MapInternal +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Primitive.SmallArray + ( SmallArray, + emptySmallArray, + indexSmallArray, + mapSmallArray', + sizeofSmallArray, + smallArrayFromList, + ) +import Moonlight.Delta.Patch.Internal.Builder +import Moonlight.Delta.Patch.Internal.Cell +import Moonlight.Delta.Patch.Internal.Cursor +import Moonlight.Delta.Patch.Internal.Page +import Moonlight.Delta.Patch.Internal.Types +import Prelude hiding (lookup) + +empty :: Patch key value +empty = + SmallPatch emptySmallArray +{-# INLINE empty #-} + +singleton :: key -> CellPatch value -> Patch key value +singleton key cell = + SmallPatch (smallArrayFromList [Cell key cell]) +{-# INLINE singleton #-} + +fromList :: (PatchKey key, PatchValue value) => [(key, CellPatch value)] -> Patch key value +fromList = + fromMapEntries . Map.fromList +{-# INLINABLE fromList #-} + +fromAscList :: (PatchKey key, PatchValue value) => [(key, CellPatch value)] -> Patch key value +fromAscList entries = + case consolidateAscending entries of + Nothing -> + fromList entries + Just distinctEntries -> + fromDistinctAscList distinctEntries +{-# INLINABLE fromAscList #-} + +smallFromDistinctAscList :: [(key, CellPatch value)] -> Patch key value +smallFromDistinctAscList entries = + SmallPatch (smallArrayFromList (fmap (uncurry Cell) entries)) +{-# INLINE smallFromDistinctAscList #-} + +entriesShorterThan :: Int -> [a] -> Bool +entriesShorterThan limit = + go limit + where + go :: Int -> [entry] -> Bool + go remaining entries + | remaining <= 0 = + False + | otherwise = + case entries of + [] -> + True + _ : rest -> + go (remaining - 1) rest +{-# INLINE entriesShorterThan #-} + +consolidateAscending :: forall key value. Ord key => [(key, value)] -> Maybe [(key, value)] +consolidateAscending entries = + case entries of + [] -> + Just [] + firstEntry : remainingEntries -> + reverse <$> collect firstEntry remainingEntries [] + where + collect :: (key, value) -> [(key, value)] -> [(key, value)] -> Maybe [(key, value)] + collect currentEntry [] accumulated = + Just (currentEntry : accumulated) + collect currentEntry@(key, _value) (nextEntry@(nextKey, _nextValue) : remainingEntries) accumulated = + case compare key nextKey of + LT -> + collect nextEntry remainingEntries (currentEntry : accumulated) + EQ -> + collect nextEntry remainingEntries accumulated + GT -> + Nothing +{-# INLINABLE consolidateAscending #-} + +fromDistinctAscList :: (PatchKey key, PatchValue value) => [(key, CellPatch value)] -> Patch key value +fromDistinctAscList entries = + if entriesShorterThan smallFormThreshold entries + then smallFromDistinctAscList entries + else runST $ do + builder <- newBuilder + traverse_ (uncurry (appendCell builder)) entries + finishBuilder builder +{-# INLINABLE fromDistinctAscList #-} + +fromMapEntries :: (PatchKey key, PatchValue value) => Map key (CellPatch value) -> Patch key value +fromMapEntries entries + | Map.size entries < smallFormThreshold = + smallFromDistinctAscList (Map.toAscList entries) + | otherwise = + runST $ do + builder <- newBuilder + appendMapCells builder entries + finishBuilder builder +{-# INLINABLE fromMapEntries #-} + +appendMapCells :: (PatchKey key, PatchValue value) => Builder s key value -> Map key (CellPatch value) -> ST s () +appendMapCells builder entries = + case entries of + MapInternal.Tip -> + pure () + MapInternal.Bin _treeSize key cell left right -> do + appendMapCells builder left + appendCell builder key cell + appendMapCells builder right +{-# INLINABLE appendMapCells #-} + +appendCell :: (PatchKey key, PatchValue value) => Builder s key value -> key -> CellPatch value -> ST s () +appendCell builder key cell = + appendTransition builder key (cellBeforeEndpoint cell) (cellAfterEndpoint cell) +{-# INLINE appendCell #-} + +toAscList :: Patch key value -> [(key, CellPatch value)] +toAscList = + foldWithKey + (\key rest -> (key, AssertAbsent) : rest) + (\key after rest -> (key, Insert after) : rest) + (\key before rest -> (key, Delete before) : rest) + (\key before after rest -> (key, Replace before after) : rest) + [] +{-# INLINE toAscList #-} + +lookup :: Ord key => key -> Patch key value -> Maybe (CellPatch value) +lookup key patch = + case patch of + SmallPatch cells -> + lookupSmall key cells 0 (sizeofSmallArray cells) + PagedPatch _count pages -> + case pageForKey key pages of + Nothing -> + Nothing + Just (maximumKey, page) -> + fmap (rowCellAt page) (pageLookupIndex key maximumKey page) +{-# INLINABLE lookup #-} + +lookupSmall :: Ord key => key -> SmallArray (Cell key value) -> Int -> Int -> Maybe (CellPatch value) +lookupSmall key cells !index !count + | index == count = + Nothing + | otherwise = + case indexSmallArray cells index of + Cell currentKey cell -> + case compare key currentKey of + LT -> + Nothing + EQ -> + Just cell + GT -> + lookupSmall key cells (index + 1) count +{-# INLINABLE lookupSmall #-} + +mapMaybeWithKey :: (key -> CellPatch value -> Maybe value') -> Patch key value -> Map key value' +mapMaybeWithKey project patch = + Map.fromDistinctAscList + ( foldWithKey + (\key rest -> emit key AssertAbsent rest) + (\key after rest -> emit key (Insert after) rest) + (\key before rest -> emit key (Delete before) rest) + (\key before after rest -> emit key (Replace before after) rest) + [] + patch + ) + where + emit key cell rest = + case project key cell of + Nothing -> rest + Just !projected -> (key, projected) : rest +{-# INLINE mapMaybeWithKey #-} + +foldPageRight :: + (key -> result -> result) -> + (key -> value -> result -> result) -> + (key -> value -> result -> result) -> + (key -> value -> value -> result -> result) -> + key -> + Page key value -> + result -> + result +foldPageRight onAssertAbsent onInsert onDelete onReplace maximumKey page initial = + case (columnView count beforeColumn, columnView count afterColumn) of + (ColumnView beforeMask beforeValues, ColumnView afterMask afterValues) -> + go beforeMask beforeValues afterMask afterValues 0 0 0 + where + !count = pageCount page + !beforeColumn = pageBeforeColumn page + !afterColumn = pageAfterColumn page + + go !beforeMask !beforeValues !afterMask !afterValues !index !beforePacked !afterPacked + | index == count = + initial + | otherwise = + let !key = pageKeyAt maximumKey page index + !beforePresent = testBit beforeMask index + !afterPresent = testBit afterMask index + !nextBeforePacked = if beforePresent then beforePacked + 1 else beforePacked + !nextAfterPacked = if afterPresent then afterPacked + 1 else afterPacked + rest = go beforeMask beforeValues afterMask afterValues (index + 1) nextBeforePacked nextAfterPacked + in case (beforePresent, afterPresent) of + (False, False) -> onAssertAbsent key rest + (False, True) -> onInsert key (valueColumnAt afterValues afterPacked) rest + (True, False) -> onDelete key (valueColumnAt beforeValues beforePacked) rest + (True, True) -> onReplace key (valueColumnAt beforeValues beforePacked) (valueColumnAt afterValues afterPacked) rest +{-# INLINE foldPageRight #-} + +foldPageLeftStrict :: + (result -> key -> result) -> + (result -> key -> value -> result) -> + (result -> key -> value -> result) -> + (result -> key -> value -> value -> result) -> + result -> + key -> + Page key value -> + result +foldPageLeftStrict onAssertAbsent onInsert onDelete onReplace initial maximumKey page = + case (columnView count beforeColumn, columnView count afterColumn) of + (ColumnView beforeMask beforeValues, ColumnView afterMask afterValues) -> + go beforeMask beforeValues afterMask afterValues 0 0 0 initial + where + !count = pageCount page + !beforeColumn = pageBeforeColumn page + !afterColumn = pageAfterColumn page + + go !beforeMask !beforeValues !afterMask !afterValues !index !beforePacked !afterPacked !accumulator + | index == count = + accumulator + | otherwise = + let !key = pageKeyAt maximumKey page index + !beforePresent = testBit beforeMask index + !afterPresent = testBit afterMask index + !nextAccumulator = + case (beforePresent, afterPresent) of + (False, False) -> onAssertAbsent accumulator key + (False, True) -> onInsert accumulator key (valueColumnAt afterValues afterPacked) + (True, False) -> onDelete accumulator key (valueColumnAt beforeValues beforePacked) + (True, True) -> onReplace accumulator key (valueColumnAt beforeValues beforePacked) (valueColumnAt afterValues afterPacked) + !nextBeforePacked = if beforePresent then beforePacked + 1 else beforePacked + !nextAfterPacked = if afterPresent then afterPacked + 1 else afterPacked + in go beforeMask beforeValues afterMask afterValues (index + 1) nextBeforePacked nextAfterPacked nextAccumulator +{-# INLINE foldPageLeftStrict #-} + +foldWithKey :: + (key -> result -> result) -> + (key -> value -> result -> result) -> + (key -> value -> result -> result) -> + (key -> value -> value -> result -> result) -> + result -> + Patch key value -> + result +foldWithKey onAssertAbsent onInsert onDelete onReplace initial patch = + case patch of + SmallPatch cells -> + foldSmallRight onAssertAbsent onInsert onDelete onReplace initial cells + PagedPatch _count pages -> + Map.foldrWithKey (foldPageRight onAssertAbsent onInsert onDelete onReplace) initial pages +{-# INLINE foldWithKey #-} + +foldSmallRight :: + (key -> result -> result) -> + (key -> value -> result -> result) -> + (key -> value -> result -> result) -> + (key -> value -> value -> result -> result) -> + result -> + SmallArray (Cell key value) -> + result +foldSmallRight onAssertAbsent onInsert onDelete onReplace initial cells = + go 0 + where + !count = sizeofSmallArray cells + go !index + | index == count = + initial + | otherwise = + case indexSmallArray cells index of + Cell key cell -> + let rest = go (index + 1) + in case cell of + AssertAbsent -> + onAssertAbsent key rest + Insert after -> + onInsert key after rest + Delete before -> + onDelete key before rest + Replace before after -> + onReplace key before after rest +{-# INLINE foldSmallRight #-} + +foldWithKey' :: + (result -> key -> result) -> + (result -> key -> value -> result) -> + (result -> key -> value -> result) -> + (result -> key -> value -> value -> result) -> + result -> + Patch key value -> + result +foldWithKey' onAssertAbsent onInsert onDelete onReplace initial patch = + case patch of + SmallPatch cells -> + foldSmallLeftStrict onAssertAbsent onInsert onDelete onReplace initial cells + PagedPatch _count pages -> + Map.foldlWithKey' (foldPageLeftStrict onAssertAbsent onInsert onDelete onReplace) initial pages +{-# INLINE foldWithKey' #-} + +foldSmallLeftStrict :: + (result -> key -> result) -> + (result -> key -> value -> result) -> + (result -> key -> value -> result) -> + (result -> key -> value -> value -> result) -> + result -> + SmallArray (Cell key value) -> + result +foldSmallLeftStrict onAssertAbsent onInsert onDelete onReplace initial cells = + go 0 initial + where + !count = sizeofSmallArray cells + go !index !accumulator + | index == count = + accumulator + | otherwise = + case indexSmallArray cells index of + Cell key cell -> + let !nextAccumulator = + case cell of + AssertAbsent -> + onAssertAbsent accumulator key + Insert after -> + onInsert accumulator key after + Delete before -> + onDelete accumulator key before + Replace before after -> + onReplace accumulator key before after + in go (index + 1) nextAccumulator +{-# INLINE foldSmallLeftStrict #-} + +traverseWithKey :: + (Applicative effect, PatchKey key, PatchValue value') => + (key -> CellPatch value -> effect (CellPatch value')) -> + Patch key value -> + effect (Patch key value') +traverseWithKey step patch = + fromAscList <$> traverse traverseCell (toAscList patch) + where + traverseCell (key, cell) = + fmap (\nextCell -> (key, nextCell)) (step key cell) +{-# INLINE traverseWithKey #-} + +invert :: Patch key value -> Patch key value +invert patch = + case patch of + SmallPatch cells -> + SmallPatch (mapSmallArray' invertCell cells) + PagedPatch count pages -> + PagedPatch count (Map.map invertPage pages) +{-# INLINE invert #-} + +invertCell :: Cell key value -> Cell key value +invertCell (Cell key cell) = + Cell key (invertCellPatch cell) +{-# INLINE invertCell #-} + +invertCellPatch :: CellPatch value -> CellPatch value +invertCellPatch cell = + case cell of + AssertAbsent -> + AssertAbsent + Insert after -> + Delete after + Delete before -> + Insert before + Replace before after -> + Replace after before +{-# INLINE invertCellPatch #-} + +diff :: forall key value. (PatchKey key, PatchValue value) => Map key value -> Map key value -> Patch key value +diff before after = + normalize + ( runST $ do + builder <- newBuilder + appendDiff builder (ascCursor before) (ascCursor after) + finishBuilder builder + ) + where + appendDiff :: Builder s key value -> AscCursor key value -> AscCursor key value -> ST s () + appendDiff builder beforeCursor afterCursor = + case (beforeCursor, afterCursor) of + (AscEnd, AscEnd) -> + pure () + (AscCursor beforeKey beforeValue _ _, AscEnd) -> do + appendTransition builder beforeKey (EndpointPresent beforeValue) EndpointAbsent + appendDiff builder (ascAdvance beforeCursor) AscEnd + (AscEnd, AscCursor afterKey afterValue _ _) -> do + appendTransition builder afterKey EndpointAbsent (EndpointPresent afterValue) + appendDiff builder AscEnd (ascAdvance afterCursor) + (AscCursor beforeKey beforeValue _ _, AscCursor afterKey afterValue _ _) -> + case compare beforeKey afterKey of + LT -> do + appendTransition builder beforeKey (EndpointPresent beforeValue) EndpointAbsent + appendDiff builder (ascAdvance beforeCursor) afterCursor + GT -> do + appendTransition builder afterKey EndpointAbsent (EndpointPresent afterValue) + appendDiff builder beforeCursor (ascAdvance afterCursor) + EQ -> do + if beforeValue == afterValue + then pure () + else appendTransition builder afterKey (EndpointPresent beforeValue) (EndpointPresent afterValue) + appendDiff builder (ascAdvance beforeCursor) (ascAdvance afterCursor) +{-# INLINABLE diff #-} diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Cursor.hs b/src-patch/Moonlight/Delta/Patch/Internal/Cursor.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Cursor.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- Loop-local rebinding (state/cursor/coverage) is the engine idiom here; shadowing is deliberate. +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Moonlight.Delta.Patch.Internal.Cursor + ( AscCursor (..), + ascCursor, + ascAdvance, + Cursor (CursorEnd), + cursor, + fromAsc, + advanceRow, + advancePage, + cursorPageStart, + currentKey, + currentRow, + beforeMaybe, + afterMaybe, + ) +where + +import Data.Map.Internal qualified as MapInternal +import Data.Map.Strict (Map) +import Moonlight.Delta.Patch.Internal.Page + ( ColumnView, + advancePackedIndex, + columnEndpointFromView, + columnMaybeAt, + columnView, + ) +import Moonlight.Delta.Patch.Internal.Types + ( Endpoint, + Page (..), + pageKeyAt, + ) +import Prelude + +data AscStack key value + = AscStackEnd + | AscStackNode !key value !(Map key value) !(AscStack key value) + +data AscCursor key value + = AscEnd + | AscCursor !key value !(Map key value) !(AscStack key value) + +ascCursor :: forall key value. Map key value -> AscCursor key value +ascCursor tree = + descend tree AscStackEnd + where + descend :: Map key value -> AscStack key value -> AscCursor key value + descend entries stack = + case entries of + MapInternal.Tip -> + popStack stack + MapInternal.Bin _ key value left right -> + descend left (AscStackNode key value right stack) + + popStack :: AscStack key value -> AscCursor key value + popStack stack = + case stack of + AscStackEnd -> + AscEnd + AscStackNode key value right rest -> + AscCursor key value right rest +{-# INLINE ascCursor #-} + +ascAdvance :: forall key value. AscCursor key value -> AscCursor key value +ascAdvance cursor = + case cursor of + AscEnd -> + AscEnd + AscCursor _key _value right stack -> + descend right stack + where + descend :: Map key value -> AscStack key value -> AscCursor key value + descend entries remaining = + case entries of + MapInternal.Tip -> + popStack remaining + MapInternal.Bin _ key value left nextRight -> + descend left (AscStackNode key value nextRight remaining) + + popStack :: AscStack key value -> AscCursor key value + popStack remaining = + case remaining of + AscStackEnd -> + AscEnd + AscStackNode key value nextRight rest -> + AscCursor key value nextRight rest +{-# INLINE ascAdvance #-} + +data PatchEndpointSide + = PatchBefore + | PatchAfter + +data ColumnCursor (side :: PatchEndpointSide) value = ColumnCursor + { columnCursorPackedIndex :: {-# UNPACK #-} !Int, + columnCursorView :: {-# UNPACK #-} !(ColumnView value) + } + +data ActiveCursor key value = ActiveCursor + { activeCursorMaximumKey :: !key, + activeCursorPage :: !(Page key value), + activeCursorLogicalIndex :: {-# UNPACK #-} !Int, + activeCursorBefore :: {-# UNPACK #-} !(ColumnCursor 'PatchBefore value), + activeCursorAfter :: {-# UNPACK #-} !(ColumnCursor 'PatchAfter value), + activeCursorRemainingPages :: !(AscCursor key (Page key value)) + } + +data Cursor key value + = CursorEnd + | CursorActive {-# UNPACK #-} !(ActiveCursor key value) + +cursor :: Map key (Page key value) -> Cursor key value +cursor = + fromAsc . ascCursor +{-# INLINE cursor #-} + +fromAsc :: AscCursor key (Page key value) -> Cursor key value +fromAsc cursor = + case cursor of + AscEnd -> + CursorEnd + AscCursor maximumKey page _right _stack -> + CursorActive + ActiveCursor + { activeCursorMaximumKey = maximumKey, + activeCursorPage = page, + activeCursorLogicalIndex = 0, + activeCursorBefore = + ColumnCursor + { columnCursorPackedIndex = 0, + columnCursorView = columnView (pageCount page) (pageBeforeColumn page) + }, + activeCursorAfter = + ColumnCursor + { columnCursorPackedIndex = 0, + columnCursorView = columnView (pageCount page) (pageAfterColumn page) + }, + activeCursorRemainingPages = ascAdvance cursor + } +{-# INLINE fromAsc #-} + +advancePage :: Cursor key value -> Cursor key value +advancePage cursor = + case cursor of + CursorEnd -> + CursorEnd + CursorActive activeCursor -> + fromAsc (activeCursorRemainingPages activeCursor) +{-# INLINE advancePage #-} + +advanceRow :: Cursor key value -> Cursor key value +advanceRow cursor = + case cursor of + CursorEnd -> + CursorEnd + CursorActive activeCursor -> + let !logicalIndex = activeCursorLogicalIndex activeCursor + !nextLogicalIndex = logicalIndex + 1 + in if nextLogicalIndex == pageCount (activeCursorPage activeCursor) + then fromAsc (activeCursorRemainingPages activeCursor) + else + CursorActive + activeCursor + { activeCursorLogicalIndex = nextLogicalIndex, + activeCursorBefore = advanceColumnCursor logicalIndex (activeCursorBefore activeCursor), + activeCursorAfter = advanceColumnCursor logicalIndex (activeCursorAfter activeCursor) + } +{-# INLINE advanceRow #-} + +advanceColumnCursor :: Int -> ColumnCursor side value -> ColumnCursor side value +advanceColumnCursor logicalIndex columnCursor = + columnCursor + { columnCursorPackedIndex = + advancePackedIndex + (columnCursorView columnCursor) + logicalIndex + (columnCursorPackedIndex columnCursor) + } +{-# INLINE advanceColumnCursor #-} + +cursorPageStart :: Cursor key value -> Maybe (key, Page key value) +cursorPageStart cursor = + case cursor of + CursorEnd -> + Nothing + CursorActive activeCursor + | activeCursorLogicalIndex activeCursor == 0 -> + Just (activeCursorMaximumKey activeCursor, activeCursorPage activeCursor) + | otherwise -> + Nothing +{-# INLINE cursorPageStart #-} + +currentKey :: Cursor key value -> Maybe key +currentKey cursor = + case cursor of + CursorEnd -> + Nothing + CursorActive activeCursor -> + Just + ( pageKeyAt + (activeCursorMaximumKey activeCursor) + (activeCursorPage activeCursor) + (activeCursorLogicalIndex activeCursor) + ) +{-# INLINE currentKey #-} + +currentRow :: Cursor key value -> Maybe (key, Endpoint value, Endpoint value) +currentRow cursor = + case cursor of + CursorEnd -> + Nothing + CursorActive activeCursor -> + let !logicalIndex = activeCursorLogicalIndex activeCursor + in Just + ( pageKeyAt + (activeCursorMaximumKey activeCursor) + (activeCursorPage activeCursor) + logicalIndex, + columnCursorEndpoint logicalIndex (activeCursorBefore activeCursor), + columnCursorEndpoint logicalIndex (activeCursorAfter activeCursor) + ) +{-# INLINE currentRow #-} + +columnCursorEndpoint :: Int -> ColumnCursor side value -> Endpoint value +columnCursorEndpoint logicalIndex columnCursor = + columnEndpointFromView + (columnCursorView columnCursor) + logicalIndex + (columnCursorPackedIndex columnCursor) +{-# INLINE columnCursorEndpoint #-} + +beforeMaybe :: Cursor key value -> Maybe value +beforeMaybe = + cursorColumnValue activeCursorBefore +{-# INLINE beforeMaybe #-} + +afterMaybe :: Cursor key value -> Maybe value +afterMaybe = + cursorColumnValue activeCursorAfter +{-# INLINE afterMaybe #-} + +cursorColumnValue :: (ActiveCursor key value -> ColumnCursor side value) -> Cursor key value -> Maybe value +cursorColumnValue selectColumn cursor = + case cursor of + CursorEnd -> + Nothing + CursorActive activeCursor -> + columnCursorValue + (activeCursorLogicalIndex activeCursor) + (selectColumn activeCursor) +{-# INLINE cursorColumnValue #-} + +columnCursorValue :: Int -> ColumnCursor side value -> Maybe value +columnCursorValue logicalIndex columnCursor = + columnMaybeAt + (columnCursorView columnCursor) + logicalIndex + (columnCursorPackedIndex columnCursor) +{-# INLINE columnCursorValue #-} diff --git a/src-patch/Moonlight/Delta/Patch/Internal/IncrementalDigest.hs b/src-patch/Moonlight/Delta/Patch/Internal/IncrementalDigest.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/IncrementalDigest.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} + +module Moonlight.Delta.Patch.Internal.IncrementalDigest + ( Digest128, + DeltaHashDigest (..), + DeltaHashBuildError (..), + DeltaHashApplyError (..), + IncrementalDigest (..), + deltaHashEncodingVersion, + digest128Encoding, + digest128EncodingChunks, + ) +where + +import Data.Bits (Bits (shiftR, (.&.), (.|.))) +import Data.Foldable qualified as Foldable +import Data.Kind (Type) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Moonlight.Core + ( SipHashState, + SipKey, + StableHashDigest (..), + StableHashEncoding, + stableHashEncodingDigest, + stableHashEncodingLength, + stableHashEncodingVersion, + stableHashUpdateEncoding, + sipHashFinalize, + sipHashInit, + sipHashUpdateWord8, + sipHashUpdateWord64LE, + ) +import Moonlight.Delta.Patch.Internal.Types (ApplyError, Patch) +import Prelude + +data DeltaHashDigest = DeltaHashDigest + { deltaHashDigestLane0 :: {-# UNPACK #-} !Word64, + deltaHashDigestLane1 :: {-# UNPACK #-} !Word64 + } + deriving stock (Eq, Ord, Show, Read, Generic) + +type Digest128 :: Type +type Digest128 = DeltaHashDigest + +data DeltaHashBuildError key = DeltaHashKeyCollision + { deltaHashCollisionDigest :: !StableHashDigest, + deltaHashExistingKey :: !key, + deltaHashIncomingKey :: !key + } + deriving stock (Eq, Ord, Show) + +data DeltaHashApplyError key value + = DeltaHashPatchRejected !(ApplyError key value) + | DeltaHashUpdateRejected !(DeltaHashBuildError key) + deriving stock (Eq, Ord, Show) + +class IncrementalDigest (derived :: Type -> Type -> Type) where + type IncrementalDigestError derived key value :: Type + empty :: (key -> StableHashEncoding) -> (value -> StableHashEncoding) -> derived key value + applyPatch :: + (Ord key, Eq value) => + Patch key value -> + derived key value -> + Either (IncrementalDigestError derived key value) (derived key value) + digest :: derived key value -> Digest128 + +deltaHashEncodingVersion :: Word64 +deltaHashEncodingVersion = 2 + +digest128Encoding :: SipKey -> SipKey -> StableHashEncoding -> Digest128 +digest128Encoding lane0Key lane1Key encoding = + DeltaHashDigest (stableHashDigestWord lane0Key encoding) (stableHashDigestWord lane1Key encoding) + +digest128EncodingChunks :: + Foldable values => + SipKey -> + SipKey -> + (value -> StableHashEncoding) -> + values value -> + Digest128 +digest128EncodingChunks lane0Key lane1Key project values = + finalizeDigest128State (Foldable.foldl' absorbEncoding initialState values) + where + !chunkCount = fromIntegral (Foldable.length values) + !initialState = + Digest128HashState + (framedChunksSeed lane0Key chunkCount) + (framedChunksSeed lane1Key chunkCount) + absorbEncoding (Digest128HashState lane0 lane1) value = + let !encoding = project value + !encodedLength = fromIntegral (stableHashEncodingLength encoding) + in Digest128HashState + (stableHashUpdateEncoding (sipHashUpdateCompactWord64 lane0 encodedLength) encoding) + (stableHashUpdateEncoding (sipHashUpdateCompactWord64 lane1 encodedLength) encoding) + +data Digest128HashState = Digest128HashState !SipHashState !SipHashState + +finalizeDigest128State :: Digest128HashState -> Digest128 +finalizeDigest128State (Digest128HashState lane0 lane1) = + DeltaHashDigest (sipHashFinalize lane0) (sipHashFinalize lane1) + +stableHashDigestWord :: SipKey -> StableHashEncoding -> Word64 +stableHashDigestWord sipKey encoding = + case stableHashEncodingDigest sipKey encoding of + StableHashDigest digestWord -> digestWord + +framedChunksSeed :: SipKey -> Word64 -> SipHashState +framedChunksSeed sipKey = + sipHashUpdateCompactWord64 + (sipHashUpdateWord64LE (sipHashInit sipKey) stableHashEncodingVersion) + +sipHashUpdateCompactWord64 :: SipHashState -> Word64 -> SipHashState +sipHashUpdateCompactWord64 state wordValue = + let !byteValue = fromIntegral (wordValue .&. 0x7f) + !remainingValue = wordValue `shiftR` 7 + !updatedState = + sipHashUpdateWord8 state (if remainingValue == 0 then byteValue else byteValue .|. 0x80) + in if remainingValue == 0 + then updatedState + else sipHashUpdateCompactWord64 updatedState remainingValue diff --git a/src-patch/Moonlight/Delta/Patch/Internal/MerkleDeltaHash.hs b/src-patch/Moonlight/Delta/Patch/Internal/MerkleDeltaHash.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/MerkleDeltaHash.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE BangPatterns #-} + +module Moonlight.Delta.Patch.Internal.MerkleDeltaHash + ( MerkleDeltaHash, + buildMerkleDeltaHash, + merkleDeltaHashState, + merkleDeltaHashDigest, + applyMerkleDeltaHash, + deltaHashFlatMaximumSize, + ) +where + +import Data.Bits + ( Bits (complement, shiftL, xor, (.&.), (.|.)), + FiniteBits (countLeadingZeros, finiteBitSize), + ) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Word (Word64) +import Moonlight.Core + ( SipKey (..), + StableHashDigest (..), + StableHashEncoding, + defaultStableHashKey, + ) +import Moonlight.Delta.Patch.Internal.Apply qualified as Patch +import Moonlight.Delta.Patch.Internal.Construction qualified as Patch +import Moonlight.Delta.Patch.Internal.IncrementalDigest + ( DeltaHashApplyError (..), + DeltaHashBuildError (..), + DeltaHashDigest, + IncrementalDigest (..), + digest128EncodingChunks, + ) +import Moonlight.Delta.Patch.Internal.NodeCommitment qualified as Node +import Moonlight.Delta.Patch.Internal.Types (Patch) +import Prelude + +data MerkleDeltaHash key value = MerkleDeltaHash + { merkleDeltaHashKeyEncoding :: !(key -> StableHashEncoding), + merkleDeltaHashValueEncoding :: !(value -> StableHashEncoding), + merkleDeltaHashAuthoritativeState :: !(Map key value), + merkleDeltaHashDerivedView :: !(MerkleDeltaHashView key) + } + +data MerkleDeltaHashView key + = FlatStableHash !DeltaHashDigest + | IncrementalMerkleHash !(MerkleTrie key) + +data MerkleTrie key + = MerkleEmpty + | MerkleLeaf {-# UNPACK #-} !Word64 !key !DeltaHashDigest + | MerkleBranch + {-# UNPACK #-} !Word64 + {-# UNPACK #-} !Word64 + !(MerkleTrie key) + !(MerkleTrie key) + !DeltaHashDigest + +buildMerkleDeltaHash :: + Eq key => + (key -> StableHashEncoding) -> + (value -> StableHashEncoding) -> + Map key value -> + Either (DeltaHashBuildError key) (MerkleDeltaHash key value) +buildMerkleDeltaHash encodeKey encodeValue authoritativeState = + fmap + (MerkleDeltaHash encodeKey encodeValue authoritativeState) + (buildMerkleDeltaHashView encodeKey encodeValue authoritativeState) + +merkleDeltaHashState :: MerkleDeltaHash key value -> Map key value +merkleDeltaHashState = + merkleDeltaHashAuthoritativeState + +merkleDeltaHashDigest :: MerkleDeltaHash key value -> DeltaHashDigest +merkleDeltaHashDigest = + merkleDeltaHashViewDigest . merkleDeltaHashDerivedView + +applyMerkleDeltaHash :: + (Ord key, Eq value) => + Patch key value -> + MerkleDeltaHash key value -> + Either (DeltaHashApplyError key value) (MerkleDeltaHash key value) +applyMerkleDeltaHash patchValue currentMerkleDeltaHash = do + updatedState <- + either + (Left . DeltaHashPatchRejected) + Right + (Patch.apply patchValue (merkleDeltaHashAuthoritativeState currentMerkleDeltaHash)) + updatedView <- + either + (Left . DeltaHashUpdateRejected) + Right + ( updateMerkleDeltaHashView + (merkleDeltaHashKeyEncoding currentMerkleDeltaHash) + (merkleDeltaHashValueEncoding currentMerkleDeltaHash) + (merkleDeltaHashAuthoritativeState currentMerkleDeltaHash) + patchValue + updatedState + (merkleDeltaHashDerivedView currentMerkleDeltaHash) + ) + pure + MerkleDeltaHash + { merkleDeltaHashKeyEncoding = merkleDeltaHashKeyEncoding currentMerkleDeltaHash, + merkleDeltaHashValueEncoding = merkleDeltaHashValueEncoding currentMerkleDeltaHash, + merkleDeltaHashAuthoritativeState = updatedState, + merkleDeltaHashDerivedView = updatedView + } + +buildMerkleDeltaHashView :: + Eq key => + (key -> StableHashEncoding) -> + (value -> StableHashEncoding) -> + Map key value -> + Either (DeltaHashBuildError key) (MerkleDeltaHashView key) +buildMerkleDeltaHashView encodeKey encodeValue authoritativeState + | usesFlatStableHash authoritativeState = + Right (FlatStableHash (flatStateDigest encodeKey encodeValue authoritativeState)) + | otherwise = + fmap IncrementalMerkleHash (buildMerkleTrie encodeKey encodeValue authoritativeState) + +updateMerkleDeltaHashView :: + Ord key => + (key -> StableHashEncoding) -> + (value -> StableHashEncoding) -> + Map key value -> + Patch key value -> + Map key value -> + MerkleDeltaHashView key -> + Either (DeltaHashBuildError key) (MerkleDeltaHashView key) +updateMerkleDeltaHashView encodeKey encodeValue authoritativeState patchValue updatedState currentView + | usesFlatStableHash updatedState = + Right (FlatStableHash (flatStateDigest encodeKey encodeValue updatedState)) + | otherwise = + case currentView of + FlatStableHash _digest -> + fmap IncrementalMerkleHash (buildMerkleTrie encodeKey encodeValue updatedState) + IncrementalMerkleHash trie -> + fmap IncrementalMerkleHash (applyPatchToTrie encodeKey encodeValue authoritativeState patchValue trie) + +merkleDeltaHashViewDigest :: MerkleDeltaHashView key -> DeltaHashDigest +merkleDeltaHashViewDigest view = + case view of + FlatStableHash digestValue -> digestValue + IncrementalMerkleHash trie -> merkleTrieDigest trie + +usesFlatStableHash :: Map key value -> Bool +usesFlatStableHash authoritativeState = + Map.size authoritativeState <= deltaHashFlatMaximumSize + +flatStateDigest :: + (key -> StableHashEncoding) -> + (value -> StableHashEncoding) -> + Map key value -> + DeltaHashDigest +flatStateDigest encodeKey encodeValue authoritativeState = + digest128EncodingChunks + defaultStableHashKey + flatSipKeyLane1 + (either encodeKey encodeValue) + (flatStateEncodings authoritativeState) + +flatStateEncodings :: Map key value -> [Either key value] +flatStateEncodings = + Map.foldrWithKey (\key value encodings -> Left key : Right value : encodings) [] + +buildMerkleTrie :: + Eq key => + (key -> StableHashEncoding) -> + (value -> StableHashEncoding) -> + Map key value -> + Either (DeltaHashBuildError key) (MerkleTrie key) +buildMerkleTrie encodeKey encodeValue = + Map.foldlWithKey' insertEntry (Right MerkleEmpty) + where + insertEntry accumulated key value = + accumulated >>= insertEncodedValue encodeKey encodeValue key value + +applyPatchToTrie :: + Ord key => + (key -> StableHashEncoding) -> + (value -> StableHashEncoding) -> + Map key value -> + Patch key value -> + MerkleTrie key -> + Either (DeltaHashBuildError key) (MerkleTrie key) +applyPatchToTrie encodeKey encodeValue authoritativeState patchValue initialTrie = + Patch.foldWithKey' + const + (\accumulated key after -> accumulated >>= insertEncodedValue encodeKey encodeValue key after) + (\accumulated key _before -> fmap (deleteAuthoritativeKey encodeKey authoritativeState key) accumulated) + ( \accumulated key _before after -> + accumulated + >>= replaceAuthoritativeKey encodeKey encodeValue authoritativeState key after + ) + (Right initialTrie) + patchValue + +insertEncodedValue :: + Eq key => + (key -> StableHashEncoding) -> + (value -> StableHashEncoding) -> + key -> + value -> + MerkleTrie key -> + Either (DeltaHashBuildError key) (MerkleTrie key) +insertEncodedValue encodeKey encodeValue key value = + insertMerkleLeaf + (stableHashPathWord (encodeKey key)) + key + (stableHashValueWord (encodeValue value)) + +deleteEncodedKey :: + Eq key => + (key -> StableHashEncoding) -> + key -> + MerkleTrie key -> + MerkleTrie key +deleteEncodedKey encodeKey key = + deleteMerkleLeaf (stableHashPathWord (encodeKey key)) key + +deleteAuthoritativeKey :: + Ord key => + (key -> StableHashEncoding) -> + Map key value -> + key -> + MerkleTrie key -> + MerkleTrie key +deleteAuthoritativeKey encodeKey authoritativeState patchKey trie = + case Map.lookupGE patchKey authoritativeState of + Just (storedKey, _value) + | compare storedKey patchKey == EQ -> deleteEncodedKey encodeKey storedKey trie + _ -> trie + +replaceAuthoritativeKey :: + Ord key => + (key -> StableHashEncoding) -> + (value -> StableHashEncoding) -> + Map key value -> + key -> + value -> + MerkleTrie key -> + Either (DeltaHashBuildError key) (MerkleTrie key) +replaceAuthoritativeKey encodeKey encodeValue authoritativeState patchKey after trie = + case Map.lookupGE patchKey authoritativeState of + Just (storedKey, _value) + | compare storedKey patchKey == EQ -> + let !storedPath = stableHashPathWord (encodeKey storedKey) + !patchPath = stableHashPathWord (encodeKey patchKey) + !withoutStoredRepresentative = + if storedPath == patchPath + then trie + else deleteMerkleLeaf storedPath storedKey trie + in insertMerkleLeaf patchPath patchKey (stableHashValueWord (encodeValue after)) withoutStoredRepresentative + _ -> insertEncodedValue encodeKey encodeValue patchKey after trie + +insertMerkleLeaf :: + Eq key => + Word64 -> + key -> + Word64 -> + MerkleTrie key -> + Either (DeltaHashBuildError key) (MerkleTrie key) +insertMerkleLeaf path key valueDigest trie = + case trie of + MerkleEmpty -> + Right (merkleLeaf path key valueDigest) + MerkleLeaf existingPath existingKey _existingDigest + | path == existingPath -> + if key == existingKey + then Right (merkleLeaf path key valueDigest) + else + Left + DeltaHashKeyCollision + { deltaHashCollisionDigest = StableHashDigest path, + deltaHashExistingKey = existingKey, + deltaHashIncomingKey = key + } + | otherwise -> + Right (linkMerkleTries path (merkleLeaf path key valueDigest) existingPath trie) + branch@(MerkleBranch prefix branchingBit left right _branchDigest) + | not (matchesPrefix path prefix branchingBit) -> + Right (linkMerkleTries path (merkleLeaf path key valueDigest) prefix branch) + | zeroAtBit path branchingBit -> + fmap + (\updatedLeft -> merkleBranch prefix branchingBit updatedLeft right) + (insertMerkleLeaf path key valueDigest left) + | otherwise -> + fmap + (\updatedRight -> merkleBranch prefix branchingBit left updatedRight) + (insertMerkleLeaf path key valueDigest right) + +deleteMerkleLeaf :: + Eq key => + Word64 -> + key -> + MerkleTrie key -> + MerkleTrie key +deleteMerkleLeaf path key trie = + case trie of + MerkleEmpty -> MerkleEmpty + MerkleLeaf existingPath existingKey _digest -> + if path == existingPath && key == existingKey then MerkleEmpty else trie + MerkleBranch prefix branchingBit left right _branchDigest + | not (matchesPrefix path prefix branchingBit) -> trie + | zeroAtBit path branchingBit -> + compactMerkleBranch prefix branchingBit (deleteMerkleLeaf path key left) right + | otherwise -> + compactMerkleBranch prefix branchingBit left (deleteMerkleLeaf path key right) + +linkMerkleTries :: + Word64 -> + MerkleTrie key -> + Word64 -> + MerkleTrie key -> + MerkleTrie key +linkMerkleTries leftPath leftTrie rightPath rightTrie = + let !branchingBit = highestDifferingBit leftPath rightPath + !prefix = maskPrefix leftPath branchingBit + in if zeroAtBit leftPath branchingBit + then merkleBranch prefix branchingBit leftTrie rightTrie + else merkleBranch prefix branchingBit rightTrie leftTrie + +compactMerkleBranch :: + Word64 -> + Word64 -> + MerkleTrie key -> + MerkleTrie key -> + MerkleTrie key +compactMerkleBranch prefix branchingBit left right = + case (left, right) of + (MerkleEmpty, remaining) -> remaining + (remaining, MerkleEmpty) -> remaining + _ -> merkleBranch prefix branchingBit left right + +merkleLeaf :: Word64 -> key -> Word64 -> MerkleTrie key +merkleLeaf path key valueDigest = + MerkleLeaf path key (Node.leafDigest Node.sipHashNodeCommitment path valueDigest) + +merkleBranch :: + Word64 -> + Word64 -> + MerkleTrie key -> + MerkleTrie key -> + MerkleTrie key +merkleBranch prefix branchingBit left right = + MerkleBranch + prefix + branchingBit + left + right + (Node.branchDigest Node.sipHashNodeCommitment prefix branchingBit (merkleTrieDigest left) (merkleTrieDigest right)) + +merkleTrieDigest :: MerkleTrie key -> DeltaHashDigest +merkleTrieDigest trie = + case trie of + MerkleEmpty -> Node.emptyDigest Node.sipHashNodeCommitment + MerkleLeaf _path _key digestValue -> digestValue + MerkleBranch _prefix _branchingBit _left _right digestValue -> digestValue + +stableHashPathWord :: StableHashEncoding -> Word64 +stableHashPathWord = + Node.localizePath Node.sipHashNodeCommitment + +stableHashValueWord :: StableHashEncoding -> Word64 +stableHashValueWord = + Node.commitValue Node.sipHashNodeCommitment + +deltaHashFlatMaximumSize :: Int +deltaHashFlatMaximumSize = + 256 + +flatSipKeyLane1 :: SipKey +flatSipKeyLane1 = + SipKey 0x6d6f6f6e6c696768 0x742d636f72652d32 + +matchesPrefix :: Word64 -> Word64 -> Word64 -> Bool +matchesPrefix path prefix branchingBit = + maskPrefix path branchingBit == prefix + +maskPrefix :: Word64 -> Word64 -> Word64 +maskPrefix path branchingBit = + path .&. complement (branchingBit .|. (branchingBit - 1)) + +zeroAtBit :: Word64 -> Word64 -> Bool +zeroAtBit path branchingBit = + path .&. branchingBit == 0 + +highestDifferingBit :: Word64 -> Word64 -> Word64 +highestDifferingBit leftPath rightPath = + let !differentBits = leftPath `xor` rightPath + !highestIndex = finiteBitSize differentBits - countLeadingZeros differentBits - 1 + in 1 `shiftL` highestIndex + +emptyMerkleDeltaHash :: + (key -> StableHashEncoding) -> + (value -> StableHashEncoding) -> + MerkleDeltaHash key value +emptyMerkleDeltaHash encodeKey encodeValue = + MerkleDeltaHash encodeKey encodeValue Map.empty (FlatStableHash (flatStateDigest encodeKey encodeValue Map.empty)) + +instance IncrementalDigest MerkleDeltaHash where + type IncrementalDigestError MerkleDeltaHash key value = DeltaHashApplyError key value + empty = emptyMerkleDeltaHash + applyPatch = applyMerkleDeltaHash + digest = merkleDeltaHashDigest diff --git a/src-patch/Moonlight/Delta/Patch/Internal/MultisetDeltaHash.hs b/src-patch/Moonlight/Delta/Patch/Internal/MultisetDeltaHash.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/MultisetDeltaHash.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE BangPatterns #-} + +module Moonlight.Delta.Patch.Internal.MultisetDeltaHash + ( MultisetDeltaHash, + buildMultisetDeltaHash, + multisetDeltaHashState, + multisetDeltaHashDigest, + applyMultisetDeltaHash, + ) +where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Vector.Unboxed qualified as UVector +import Data.Word (Word64) +import Moonlight.Algebra.Pure.LaneVector + ( LaneVector, + laneCount, + laneVectorFromLanes, + laneVectorLanes, + laneVectorZero, + ) +import Moonlight.Core + ( AdditiveGroup (sub), + AdditiveMonoid (add), + SipKey (..), + StableHashDigest (..), + StableHashEncoding, + stableHashEncodingDigest, + stableHashEncodingLength, + stableHashEncodingWord8, + stableHashEncodingWord64LE, + ) +import Moonlight.Delta.Patch.Internal.Apply qualified as Patch +import Moonlight.Delta.Patch.Internal.Construction qualified as Patch +import Moonlight.Delta.Patch.Internal.IncrementalDigest + ( DeltaHashApplyError (..), + Digest128, + IncrementalDigest (..), + deltaHashEncodingVersion, + digest128Encoding, + ) +import Moonlight.Delta.Patch.Internal.Types (Patch) +import Prelude + +data MultisetDeltaHash key value = MultisetDeltaHash + { multisetDeltaHashKeyEncoding :: !(key -> StableHashEncoding), + multisetDeltaHashValueEncoding :: !(value -> StableHashEncoding), + multisetDeltaHashAuthoritativeState :: !(Map key value), + multisetDeltaHashAccumulator :: !LaneVector + } + +buildMultisetDeltaHash :: + (key -> StableHashEncoding) -> + (value -> StableHashEncoding) -> + Map key value -> + MultisetDeltaHash key value +buildMultisetDeltaHash encodeKey encodeValue authoritativeState = + MultisetDeltaHash + { multisetDeltaHashKeyEncoding = encodeKey, + multisetDeltaHashValueEncoding = encodeValue, + multisetDeltaHashAuthoritativeState = authoritativeState, + multisetDeltaHashAccumulator = + Map.foldlWithKey' + (addEncodedEntry encodeKey encodeValue) + laneVectorZero + authoritativeState + } + +multisetDeltaHashState :: MultisetDeltaHash key value -> Map key value +multisetDeltaHashState = + multisetDeltaHashAuthoritativeState + +multisetDeltaHashDigest :: MultisetDeltaHash key value -> Digest128 +multisetDeltaHashDigest = + digestLaneVector . multisetDeltaHashAccumulator + +applyMultisetDeltaHash :: + (Ord key, Eq value) => + Patch key value -> + MultisetDeltaHash key value -> + Either (DeltaHashApplyError key value) (MultisetDeltaHash key value) +applyMultisetDeltaHash patchValue currentMultisetDeltaHash = do + updatedState <- + either + (Left . DeltaHashPatchRejected) + Right + (Patch.apply patchValue (multisetDeltaHashAuthoritativeState currentMultisetDeltaHash)) + let !encodeKey = multisetDeltaHashKeyEncoding currentMultisetDeltaHash + !encodeValue = multisetDeltaHashValueEncoding currentMultisetDeltaHash + !authoritativeState = multisetDeltaHashAuthoritativeState currentMultisetDeltaHash + !updatedAccumulator = + Patch.foldWithKey' + const + (addEncodedEntry encodeKey encodeValue) + (\accumulator key before -> + let (storedKey, storedValue) = + storedEntryRepresentative authoritativeState key before + in subtractEncodedEntry encodeKey encodeValue accumulator storedKey storedValue + ) + (\accumulator key before after -> + let (storedKey, storedValue) = + storedEntryRepresentative authoritativeState key before + in addEncodedEntry + encodeKey + encodeValue + (subtractEncodedEntry encodeKey encodeValue accumulator storedKey storedValue) + key + after + ) + (multisetDeltaHashAccumulator currentMultisetDeltaHash) + patchValue + pure + MultisetDeltaHash + { multisetDeltaHashKeyEncoding = encodeKey, + multisetDeltaHashValueEncoding = encodeValue, + multisetDeltaHashAuthoritativeState = updatedState, + multisetDeltaHashAccumulator = updatedAccumulator + } + +addEncodedEntry :: + (key -> StableHashEncoding) -> + (value -> StableHashEncoding) -> + LaneVector -> + key -> + value -> + LaneVector +addEncodedEntry encodeKey encodeValue accumulator key value = + add accumulator (expand (encodeKey key) (encodeValue value)) + +subtractEncodedEntry :: + (key -> StableHashEncoding) -> + (value -> StableHashEncoding) -> + LaneVector -> + key -> + value -> + LaneVector +subtractEncodedEntry encodeKey encodeValue accumulator key value = + sub accumulator (expand (encodeKey key) (encodeValue value)) + +expand :: StableHashEncoding -> StableHashEncoding -> LaneVector +expand keyEncoding valueEncoding = + laneVectorFromLanes + ( UVector.generate + laneCount + (\laneIndex -> + stableHashDigestWord + multisetExpansionSipKey + (multisetElementEncoding laneIndex keyEncoding valueEncoding) + ) + ) + +multisetElementEncoding :: + Int -> + StableHashEncoding -> + StableHashEncoding -> + StableHashEncoding +multisetElementEncoding laneIndex keyEncoding valueEncoding = + stableHashEncodingWord8 3 + <> stableHashEncodingWord64LE deltaHashEncodingVersion + <> stableHashEncodingWord64LE (fromIntegral (stableHashEncodingLength keyEncoding)) + <> keyEncoding + <> stableHashEncodingWord64LE (fromIntegral (stableHashEncodingLength valueEncoding)) + <> valueEncoding + <> stableHashEncodingWord64LE (fromIntegral laneIndex) + +digestLaneVector :: LaneVector -> Digest128 +digestLaneVector laneVector = + digest128Encoding + multisetDigestSipKeyLane0 + multisetDigestSipKeyLane1 + ( stableHashEncodingWord8 4 + <> stableHashEncodingWord64LE deltaHashEncodingVersion + <> stableHashEncodingWord64LE (fromIntegral laneCount) + <> UVector.foldl' + (\encoding lane -> encoding <> stableHashEncodingWord64LE lane) + mempty + (laneVectorLanes laneVector) + ) + +storedEntryRepresentative :: Ord key => Map key value -> key -> value -> (key, value) +storedEntryRepresentative authoritativeState patchKey patchValue = + case Map.lookupGE patchKey authoritativeState of + Just storedEntry@(storedKey, _storedValue) + | compare storedKey patchKey == EQ -> storedEntry + _ -> (patchKey, patchValue) + +stableHashDigestWord :: SipKey -> StableHashEncoding -> Word64 +stableHashDigestWord sipKey encoding = + case stableHashEncodingDigest sipKey encoding of + StableHashDigest digestWord -> digestWord + +multisetExpansionSipKey :: SipKey +multisetExpansionSipKey = + SipKey 0x6d6c2d64656c7461 0x6d756c74692d7632 + +multisetDigestSipKeyLane0 :: SipKey +multisetDigestSipKeyLane0 = + SipKey 0x6d6c2d64656c7461 0x6d7365742d763031 + +multisetDigestSipKeyLane1 :: SipKey +multisetDigestSipKeyLane1 = + SipKey 0x6d6c2d64656c7461 0x6d7365742d763032 + +instance IncrementalDigest MultisetDeltaHash where + type IncrementalDigestError MultisetDeltaHash key value = DeltaHashApplyError key value + empty encodeKey encodeValue = buildMultisetDeltaHash encodeKey encodeValue Map.empty + applyPatch = applyMultisetDeltaHash + digest = multisetDeltaHashDigest diff --git a/src-patch/Moonlight/Delta/Patch/Internal/NodeCommitment.hs b/src-patch/Moonlight/Delta/Patch/Internal/NodeCommitment.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/NodeCommitment.hs @@ -0,0 +1,107 @@ +module Moonlight.Delta.Patch.Internal.NodeCommitment + ( DigestSipKeys (..), + NodeCommitment (..), + SipHashNodeCommitment, + sipHashNodeCommitment, + ) +where + +import Data.Word (Word64) +import Moonlight.Core + ( SipKey (..), + StableHashDigest (..), + StableHashEncoding, + stableHashEncodingDigest, + stableHashEncodingWord8, + stableHashEncodingWord64LE, + ) +import Moonlight.Delta.Patch.Internal.IncrementalDigest + ( DeltaHashDigest (..), + Digest128, + deltaHashEncodingVersion, + digest128Encoding, + ) +import Prelude + +data DigestSipKeys = DigestSipKeys !SipKey !SipKey + +class NodeCommitment commitment where + pathSipKey :: commitment -> SipKey + valueSipKey :: commitment -> SipKey + emptySipKey :: commitment -> DigestSipKeys + leafSipKey :: commitment -> DigestSipKeys + branchSipKey :: commitment -> DigestSipKeys + + localizePath :: commitment -> StableHashEncoding -> Word64 + localizePath commitment = + stableHashDigestWord (pathSipKey commitment) + + commitValue :: commitment -> StableHashEncoding -> Word64 + commitValue commitment = + stableHashDigestWord (valueSipKey commitment) + + emptyDigest :: commitment -> Digest128 + emptyDigest commitment = + digestWithKeys + (emptySipKey commitment) + (stableHashEncodingWord8 0) + + leafDigest :: commitment -> Word64 -> Word64 -> Digest128 + leafDigest commitment path valueDigest = + digestWithKeys + (leafSipKey commitment) + ( stableHashEncodingWord8 1 + <> stableHashEncodingWord64LE deltaHashEncodingVersion + <> stableHashEncodingWord64LE path + <> stableHashEncodingWord64LE valueDigest + ) + + branchDigest :: commitment -> Word64 -> Word64 -> Digest128 -> Digest128 -> Digest128 + branchDigest commitment prefix branchingBit leftDigest rightDigest = + digestWithKeys + (branchSipKey commitment) + ( stableHashEncodingWord8 2 + <> stableHashEncodingWord64LE deltaHashEncodingVersion + <> stableHashEncodingWord64LE prefix + <> stableHashEncodingWord64LE branchingBit + <> stableHashEncodingWord64LE (deltaHashDigestLane0 leftDigest) + <> stableHashEncodingWord64LE (deltaHashDigestLane1 leftDigest) + <> stableHashEncodingWord64LE (deltaHashDigestLane0 rightDigest) + <> stableHashEncodingWord64LE (deltaHashDigestLane1 rightDigest) + ) + +data SipHashNodeCommitment = SipHashNodeCommitment + +sipHashNodeCommitment :: SipHashNodeCommitment +sipHashNodeCommitment = SipHashNodeCommitment + +instance NodeCommitment SipHashNodeCommitment where + pathSipKey _commitment = + SipKey 0x6d6c2d64656c7461 0x706174682d763031 + + valueSipKey _commitment = + SipKey 0x6d6c2d64656c7461 0x76616c752d763031 + + emptySipKey _commitment = + DigestSipKeys + (SipKey 0x6d6c2d64656c7461 0x656d70742d763031) + (SipKey 0x6d6c2d64656c7461 0x656d70742d763032) + + leafSipKey _commitment = + DigestSipKeys + (SipKey 0x6d6c2d64656c7461 0x6c6561662d763031) + (SipKey 0x6d6c2d64656c7461 0x6c6561662d763032) + + branchSipKey _commitment = + DigestSipKeys + (SipKey 0x6d6c2d64656c7461 0x6272616e2d763031) + (SipKey 0x6d6c2d64656c7461 0x6272616e2d763032) + +digestWithKeys :: DigestSipKeys -> StableHashEncoding -> Digest128 +digestWithKeys (DigestSipKeys lane0Key lane1Key) = + digest128Encoding lane0Key lane1Key + +stableHashDigestWord :: SipKey -> StableHashEncoding -> Word64 +stableHashDigestWord sipKey encoding = + case stableHashEncodingDigest sipKey encoding of + StableHashDigest digestWord -> digestWord diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Page.hs b/src-patch/Moonlight/Delta/Patch/Internal/Page.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Page.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- Loop-local rebinding (state/cursor/coverage) is the engine idiom here; shadowing is deliberate. +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Moonlight.Delta.Patch.Internal.Page + ( ColumnView (..), + validateAlignedPageBoundary, + invertPage, + replaceRecordedPage, + replacePageEntryAfter, + columnView, + columnMaybeAt, + columnEndpointFromView, + advancePackedIndex, + rowCellAt, + pageMinimumKey, + pageLookupIndex, + pageForKey, + pageForInsertion, + minimumKey, + maximumKey, + pageKeyAt, + ) +where + +import Data.Bits (Bits (complement, shiftL, testBit, (.&.), (.|.))) +import Data.List qualified as List +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Primitive.SmallArray + ( emptySmallArray, + indexSmallArray, + sizeofSmallArray, + smallArrayFromList, + ) +import Data.Word (Word64) +import Moonlight.Delta.Patch.Internal.Cell +import Moonlight.Delta.Patch.Internal.Types +import Prelude + +data ColumnView value = ColumnView + { columnViewMask :: {-# UNPACK #-} !Word64, + columnViewValues :: !(ValueColumn value) + } + +validateAlignedPageBoundary :: + forall key value error. + (Ord key, Eq value) => + (key -> Endpoint value -> Endpoint value -> error) -> + key -> + Page key value -> + EndpointColumn value -> + key -> + Page key value -> + EndpointColumn value -> + BoundaryResult error +validateAlignedPageBoundary makeError actualMaximum actualPage actualColumn requiredMaximum requiredPage requiredColumn + | pageCount actualPage /= pageCount requiredPage = + PageBoundaryDiverged + | otherwise = + case (firstPageKeyMismatch actualMaximum actualPage requiredMaximum requiredPage, firstEndpointMismatch count actualColumn requiredColumn) of + (Nothing, Nothing) -> + PageBoundaryMatched + (Just _keyMismatch, Nothing) -> + PageBoundaryDiverged + (Nothing, Just endpointMismatch) -> + endpointFailure endpointMismatch + (Just keyMismatch, Just endpointMismatch) + | keyMismatch <= endpointMismatch -> + PageBoundaryDiverged + | otherwise -> + endpointFailure endpointMismatch + where + !count = pageCount actualPage + + endpointFailure endpointMismatch = + PageBoundaryRejected + ( makeError + (pageKeyAt requiredMaximum requiredPage endpointMismatch) + (endpointAtByScan actualColumn endpointMismatch) + (endpointAtByScan requiredColumn endpointMismatch) + ) +{-# INLINABLE validateAlignedPageBoundary #-} + +firstPageKeyMismatch :: + Ord key => + key -> + Page key leftValue -> + key -> + Page key rightValue -> + Maybe Int +firstPageKeyMismatch leftMaximum leftPage rightMaximum rightPage = + case firstPrefixKeyMismatch (pagePrefixKeys leftPage) (pagePrefixKeys rightPage) of + Just mismatch -> + Just mismatch + Nothing + | compare leftMaximum rightMaximum == EQ -> + Nothing + | otherwise -> + Just (leftCount - 1) + where + !leftCount = pageCount leftPage + +{-# INLINE firstPageKeyMismatch #-} + +firstPrefixKeyMismatch :: Ord key => KeyColumn key -> KeyColumn key -> Maybe Int +firstPrefixKeyMismatch left right + | leftCount /= rightCount = + Just 0 + | otherwise = + case (left, right) of + (IntRangeKeys leftStart leftSize, IntRangeKeys rightStart rightSize) + | leftSize /= rightSize -> + Just 0 + | leftStart == rightStart -> + Nothing + | otherwise -> + Just 0 + (IntAffineKeys leftStart leftStep leftSize, IntAffineKeys rightStart rightStep rightSize) + | leftSize /= rightSize -> + Just 0 + | leftStart /= rightStart -> + Just 0 + | leftSize <= 1 || leftStep == rightStep -> + Nothing + | otherwise -> + Just 1 + (IntRangeKeys leftStart leftSize, IntAffineKeys rightStart rightStep rightSize) + | leftSize /= rightSize -> + Just 0 + | leftStart /= rightStart -> + Just 0 + | leftSize <= 1 || rightStep == 1 -> + Nothing + | otherwise -> + Just 1 + (IntAffineKeys leftStart leftStep leftSize, IntRangeKeys rightStart rightSize) + | leftSize /= rightSize -> + Just 0 + | leftStart /= rightStart -> + Just 0 + | leftSize <= 1 || leftStep == 1 -> + Nothing + | otherwise -> + Just 1 + _ -> + scan 0 + where + !leftCount = keyColumnCount left + !rightCount = keyColumnCount right + + scan !index + | index == leftCount = + Nothing + | compare (keyColumnAt left index) (keyColumnAt right index) == EQ = + scan (index + 1) + | otherwise = + Just index +{-# INLINABLE firstPrefixKeyMismatch #-} + +firstEndpointMismatch :: Eq value => Int -> EndpointColumn value -> EndpointColumn value -> Maybe Int +firstEndpointMismatch count left right = + case (columnView count left, columnView count right) of + (leftView, rightView) -> + scan leftView rightView 0 0 0 + where + scan !leftView !rightView !index !leftPackedIndex !rightPackedIndex + | index == count = + Nothing + | endpointsEqualValue + (columnEndpointFromView leftView index leftPackedIndex) + (columnEndpointFromView rightView index rightPackedIndex) = + scan + leftView + rightView + (index + 1) + (advancePackedIndex leftView index leftPackedIndex) + (advancePackedIndex rightView index rightPackedIndex) + | otherwise = + Just index +{-# INLINABLE firstEndpointMismatch #-} + + +replaceRecordedPage :: Ord key => key -> key -> Page key value -> Map key (Page key value) -> Map key (Page key value) +replaceRecordedPage oldMaximum updatedMaximum updatedPage = + Map.insert updatedMaximum updatedPage . Map.delete oldMaximum +{-# INLINE replaceRecordedPage #-} + +replacePageEntryAfter :: (PatchKey key, PatchValue value) => key -> Endpoint value -> Int -> key -> Page key value -> (key, Page key value) +replacePageEntryAfter key after rowIndex maximumKey page = + let !count = pageCount page + (!updatedMaximum, !updatedPrefixKeys) = replacePageKeyAt key rowIndex maximumKey page + !updatedAfterColumn = replaceColumnEndpointAt count rowIndex after (pageAfterColumn page) + in ( updatedMaximum, + page + { pagePrefixKeys = updatedPrefixKeys, + pageAfterColumn = updatedAfterColumn + } + ) +{-# INLINABLE replacePageEntryAfter #-} + +replacePageKeyAt :: PatchKey key => key -> Int -> key -> Page key value -> (key, KeyColumn key) +replacePageKeyAt key rowIndex maximumKey page = + if rowIndex + 1 == pageCount page + then (key, pagePrefixKeys page) + else (maximumKey, rebuildPrefixKeys key rowIndex page) +{-# INLINE replacePageKeyAt #-} + +rebuildPrefixKeys :: PatchKey key => key -> Int -> Page key value -> KeyColumn key +rebuildPrefixKeys replacement replacementIndex page = + buildKeyColumn (smallArrayFromList (collect 0)) + where + !count = pageCount page - 1 + + collect !index + | index == count = + [] + | index == replacementIndex = + replacement : collect (index + 1) + | otherwise = + keyColumnAt (pagePrefixKeys page) index : collect (index + 1) +{-# INLINE rebuildPrefixKeys #-} + +replaceColumnEndpointAt :: PatchValue value => Int -> Int -> Endpoint value -> EndpointColumn value -> EndpointColumn value +replaceColumnEndpointAt count replacementIndex replacement column = + columnFromEndpoints count (collect 0 0) + where + !view = columnView count column + + collect !index !packedIndex + | index == count = + [] + | index == replacementIndex = + let !nextPackedIndex = advancePackedIndex view index packedIndex + in replacement : collect (index + 1) nextPackedIndex + | otherwise = + let !endpoint = columnEndpointFromView view index packedIndex + !nextPackedIndex = advancePackedIndex view index packedIndex + in endpoint : collect (index + 1) nextPackedIndex +{-# INLINE replaceColumnEndpointAt #-} + +invertPage :: Page key value -> Page key value +invertPage page = + page + { pageBeforeColumn = pageAfterColumn page, + pageAfterColumn = pageBeforeColumn page + } +{-# INLINE invertPage #-} + +columnFromEndpoints :: forall value. PatchValue value => Int -> [Endpoint value] -> EndpointColumn value +columnFromEndpoints count endpoints = + let (!mask, !valuesReversed) = + List.foldl' collectEndpoint (0 :: Word64, []) (List.zip [0 :: Int ..] endpoints) + !values = List.reverse valuesReversed + in if mask == lowBits count + then AllPresent (valueColumnFromList values) + else Presence mask (valueColumnFromList values) + where + collectEndpoint :: (Word64, [value]) -> (Int, Endpoint value) -> (Word64, [value]) + collectEndpoint (!mask, !valuesReversed) (index, endpoint) = + case endpoint of + EndpointAbsent -> + (mask, valuesReversed) + EndpointPresent value -> + (mask .|. bitAt index, value : valuesReversed) +{-# INLINE columnFromEndpoints #-} + +valueColumnFromList :: PatchValue value => [value] -> ValueColumn value +valueColumnFromList values = + case values of + [] -> + DenseValues emptySmallArray + _ -> + valueColumnFromArray (smallArrayFromList values) +{-# INLINABLE valueColumnFromList #-} + + +bitAt :: Int -> Word64 +bitAt index = + (1 :: Word64) `shiftL` index +{-# INLINE bitAt #-} + +lowBits :: Int -> Word64 +lowBits count + | count <= 0 = + 0 + | count >= pageCapacity = + complement 0 + | otherwise = + bitAt count - 1 +{-# INLINE lowBits #-} + + +columnView :: Int -> EndpointColumn value -> ColumnView value +columnView !count column = + case column of + AllPresent values -> + ColumnView (lowBits count) values + Presence mask values -> + ColumnView (mask .&. lowBits count) values +{-# INLINE columnView #-} + +columnMaybeAt :: ColumnView value -> Int -> Int -> Maybe value +columnMaybeAt (ColumnView mask values) !logicalIndex !packedIndex = + if testBit mask logicalIndex + then Just (valueColumnAt values packedIndex) + else Nothing +{-# INLINE columnMaybeAt #-} + +columnEndpointFromView :: ColumnView value -> Int -> Int -> Endpoint value +columnEndpointFromView view logicalIndex packedIndex = + case columnMaybeAt view logicalIndex packedIndex of + Nothing -> EndpointAbsent + Just value -> EndpointPresent value +{-# INLINE columnEndpointFromView #-} + + +advancePackedIndex :: ColumnView value -> Int -> Int -> Int +advancePackedIndex (ColumnView mask _values) logicalIndex packedIndex = + if testBit mask logicalIndex + then packedIndex + 1 + else packedIndex +{-# INLINE advancePackedIndex #-} + + +endpointAtByScan :: EndpointColumn value -> Int -> Endpoint value +endpointAtByScan column target = + case columnView (target + 1) column of + view -> go view 0 0 + where + go view !index !packedIndex + | index == target = + columnEndpointFromView view index packedIndex + | otherwise = + go view (index + 1) (advancePackedIndex view index packedIndex) +{-# INLINE endpointAtByScan #-} + +endpointsEqualValue :: Eq value => Endpoint value -> Endpoint value -> Bool +endpointsEqualValue left right = + case (left, right) of + (EndpointAbsent, EndpointAbsent) -> + True + (EndpointPresent leftValue, EndpointPresent rightValue) -> + leftValue == rightValue + _ -> + False +{-# INLINE endpointsEqualValue #-} + +rowCellAt :: Page key value -> Int -> CellPatch value +rowCellAt page index = + cellFromEndpointPair + (endpointAtByScan (pageBeforeColumn page) index) + (endpointAtByScan (pageAfterColumn page) index) +{-# INLINE rowCellAt #-} + +pageMinimumKey :: key -> Page key value -> key +pageMinimumKey maximumKey page = + pageKeyAt maximumKey page 0 +{-# INLINE pageMinimumKey #-} + +pageLookupIndex :: Ord key => key -> key -> Page key value -> Maybe Int +pageLookupIndex target maximumKey page = + search 0 (pageCount page - 1) + where + search low high + | low > high = + Nothing + | otherwise = + let !middle = (low + high) `quot` 2 + !middleKey = pageKeyAt maximumKey page middle + in case compare target middleKey of + LT -> search low (middle - 1) + GT -> search (middle + 1) high + EQ -> Just middle +{-# INLINABLE pageLookupIndex #-} + +pageForKey :: Ord key => key -> Map key (Page key value) -> Maybe (key, Page key value) +pageForKey key pages = + Map.lookupGE key pages +{-# INLINE pageForKey #-} + +pageForInsertion :: Ord key => key -> Map key (Page key value) -> Maybe (key, Page key value) +pageForInsertion key pages = + case Map.lookupGE key pages of + Just pageEntry -> Just pageEntry + Nothing -> Map.lookupMax pages +{-# INLINE pageForInsertion #-} + +minimumKey :: Patch key value -> Maybe key +minimumKey patch = + case patch of + SmallPatch cells + | sizeofSmallArray cells == 0 -> + Nothing + | otherwise -> + case indexSmallArray cells 0 of + Cell key _cell -> + Just key + PagedPatch _count pages -> + case Map.lookupMin pages of + Nothing -> + Nothing + Just (maximumKey, page) -> + Just (pageKeyAt maximumKey page 0) +{-# INLINE minimumKey #-} + +maximumKey :: Patch key value -> Maybe key +maximumKey patch = + case patch of + SmallPatch cells + | sizeofSmallArray cells == 0 -> + Nothing + | otherwise -> + case indexSmallArray cells (sizeofSmallArray cells - 1) of + Cell key _cell -> + Just key + PagedPatch _count pages -> + fmap fst (Map.lookupMax pages) +{-# INLINE maximumKey #-} diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Replay.hs b/src-patch/Moonlight/Delta/Patch/Internal/Replay.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Replay.hs @@ -0,0 +1,803 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- Loop-local rebinding (state/cursor/coverage) is the engine idiom here; shadowing is deliberate. +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Moonlight.Delta.Patch.Internal.Replay + ( replay, + ) +where + +import Data.Bits (testBit) +import Data.Foldable qualified as Foldable +-- Data.Map.Internal: balance-aware spine traversal; semi-stable API accepted deliberately, pinned by containers < 0.9. +import Data.Map.Internal qualified as MapInternal +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Primitive.SmallArray + ( indexSmallArray, + sizeofSmallArray, + ) +import Moonlight.Delta.Patch.Internal.Apply + ( apply, + applyTrusted, + applyTrustedEdit, + shouldUseSparse, + ) +import Moonlight.Delta.Patch.Internal.Cell + ( cellAfter, + cellBefore, + ) +import Moonlight.Delta.Patch.Internal.Compose.Core + ( ComposeResult (..), + Coverage (..), + NewKeyPolicy (..), + composeWith, + ) +import Moonlight.Delta.Patch.Internal.Compose.SameSupport + ( SameSupport, + extendSameSupport, + reflexiveSupport, + sameSupportLatest, + spliceSameSupport, + validateBoundarySameSupport, + ) +import Moonlight.Delta.Patch.Internal.Cursor + ( AscCursor (..), + Cursor (CursorEnd), + ascAdvance, + ascCursor, + advanceRow, + afterMaybe, + beforeMaybe, + currentKey, + cursor, + ) +import Moonlight.Delta.Patch.Internal.Types + ( ApplyError (..), + EndpointColumn (..), + Cell (..), + Patch (..), + PatchKey, + PatchValue, + Page (..), + ReplayError (..), + pageCapacity, + entryCount, + valueColumnAt, + ) +import Numeric.Natural (Natural) +import Prelude + +data StateProbe key value + = ProbeFresh !(Map key value) !(AscCursor key value) + | ProbeAfter !(Map key value) !key !(AscCursor key value) + | ProbeRandom !(Map key value) + +newStateProbe :: Map key value -> StateProbe key value +newStateProbe state = + ProbeFresh state (ascCursor state) +{-# INLINE newStateProbe #-} + +probeInitialState :: Ord key => key -> StateProbe key value -> (Maybe value, StateProbe key value) +probeInitialState key probe = + case probe of + ProbeFresh state cursor -> + let (!result, !nextCursor) = lookupAscending key cursor + in (result, ProbeAfter state key nextCursor) + ProbeAfter state previousKey cursor + | previousKey < key -> + let (!result, !nextCursor) = lookupAscending key cursor + in (result, ProbeAfter state key nextCursor) + | otherwise -> + (Map.lookup key state, ProbeRandom state) + ProbeRandom state -> + (Map.lookup key state, ProbeRandom state) +{-# INLINABLE probeInitialState #-} + +lookupAscending :: Ord key => key -> AscCursor key value -> (Maybe value, AscCursor key value) +lookupAscending _ AscEnd = + (Nothing, AscEnd) +lookupAscending target cursor@(AscCursor key value _ _) = + case compare key target of + LT -> lookupAscending target (ascAdvance cursor) + EQ -> (Just value, cursor) + GT -> (Nothing, cursor) +{-# INLINABLE lookupAscending #-} + +data ReplayAccumulator key value + = ReplayStable !(SameSupport key value) + | ReplayGeneral !(Patch key value) + | ReplayArena !(Map key (Maybe value, Maybe value)) + +data SingletonReplayArena key value + = SingletonArenaAscending !key ![(key, (Maybe value, Maybe value))] + | SingletonArenaMap !(Map key (Maybe value, Maybe value)) + +data ArenaBulkChanges key value + = ArenaNoChanges + | ArenaInsertions !(Map key value) + | ArenaDeletions !(Map key ()) + | ArenaMixedChanges !(Map key value) !(Map key ()) + +data AscendingArenaRows key value = AscendingArenaRows ![(key, value)] ![(key, ())] + +data ReplayMergeCursor key value = ReplayMergeCursor !(AscCursor key value) !(AscCursor key (Maybe value, Maybe value)) + +data ReplayOutput key value = ReplayOutput !key !value !(ReplayMergeCursor key value) + +data BuildReplayResult key value = BuildReplayResult !(Map key value) !(ReplayMergeCursor key value) + +replay :: + forall patches key value. + (Foldable patches, PatchKey key, PatchValue value) => + patches (Patch key value) -> + Map key value -> + Either (ReplayError key value) (Map key value) +replay patches initialState = + case Foldable.toList patches of + [] -> + Right initialState + first : remaining -> do + probe <- validateFirstTouches 0 (newStateProbe initialState) first + continue 1 probe (ReplayStable (reflexiveSupport first)) remaining + where + continue !_patchIndex !_probe accumulator [] = + Right + ( case accumulator of + ReplayStable sameSupport -> + applyTrusted (spliceSameSupport sameSupport) initialState + ReplayGeneral patch -> + applyTrusted patch initialState + ReplayArena arena -> + applyArenaDirect arena initialState + ) + continue !patchIndex !probe accumulator (nextPatch : remaining) = + case accumulator of + ReplayStable stableRun -> + let !latest = sameSupportLatest stableRun + in case validateBoundarySameSupport (replayBoundaryError patchIndex) latest nextPatch of + Left failure -> + Left failure + Right (Just latestToNext) -> + continue + (patchIndex + 1) + probe + (ReplayStable (extendSameSupport stableRun latestToNext)) + remaining + Right Nothing -> + composeDivergent patchIndex probe (spliceSameSupport stableRun) nextPatch remaining + ReplayGeneral accumulated -> + case validateBoundarySameSupport (replayBoundaryError patchIndex) accumulated nextPatch of + Left failure -> + Left failure + Right (Just sameSupport) -> + continue (patchIndex + 1) probe (ReplayStable sameSupport) remaining + Right Nothing -> + composeDivergent patchIndex probe accumulated nextPatch remaining + ReplayArena arena -> do + nextArena <- applyPatchToArena patchIndex initialState nextPatch arena + continue (patchIndex + 1) probe (ReplayArena nextArena) remaining + + composeDivergent !patchIndex !probe !accumulated !nextPatch remaining + | useSequentialReplay accumulated nextPatch = + replaySingletonArenaFrom + patchIndex + initialState + probe + (singletonArenaFromPatch accumulated) + (nextPatch : remaining) + | otherwise = do + ComposeResult + { patch = combined, + state = nextProbe, + coverage = coverage + } <- + composeWith + (CheckNewKeys (validateInitialBefore patchIndex)) + probe + (replayBoundaryError patchIndex) + accumulated + nextPatch + let !nextAccumulator = + if useReplayArena coverage accumulated nextPatch + then ReplayArena (arenaFromPatch combined) + else + if coverageOlderOnly coverage + then ReplayGeneral combined + else ReplayStable (reflexiveSupport combined) + continue (patchIndex + 1) nextProbe nextAccumulator remaining +{-# INLINABLE replay #-} +{-# SPECIALIZE replay :: + (PatchKey key, PatchValue value) => + [Patch key value] -> + Map key value -> + Either (ReplayError key value) (Map key value) + #-} + +replaySequentiallyFrom :: + (Ord key, Eq value) => + Natural -> + Map key value -> + [Patch key value] -> + Either (ReplayError key value) (Map key value) +replaySequentiallyFrom !_patchIndex !state [] = + Right state +replaySequentiallyFrom !patchIndex !state (patch : remaining) = + case apply patch state of + Left applyError -> + Left + ReplayApplyError + { replayIndex = patchIndex, + replayApply = applyError + } + Right !nextState -> + replaySequentiallyFrom (patchIndex + 1) nextState remaining +{-# INLINABLE replaySequentiallyFrom #-} + +replaySingletonArenaFrom :: + (Ord key, Eq value) => + Natural -> + Map key value -> + StateProbe key value -> + SingletonReplayArena key value -> + [Patch key value] -> + Either (ReplayError key value) (Map key value) +replaySingletonArenaFrom !_patchIndex !initialState !_probe !arena [] = + Right (applySingletonReplayArena arena initialState) +replaySingletonArenaFrom !patchIndex !initialState !probe !arena patches@(patch : remaining) = + case singletonPatchRow patch of + Nothing -> + replaySequentiallyFrom patchIndex (applySingletonReplayArena arena initialState) patches + Just (key, expectedBefore, currentAfter) -> + case applySingletonToReplayArena patchIndex key expectedBefore currentAfter probe arena of + Left failure -> + Left failure + Right (!nextProbe, !nextArena) -> + replaySingletonArenaFrom (patchIndex + 1) initialState nextProbe nextArena remaining +{-# INLINABLE replaySingletonArenaFrom #-} + +singletonArenaFromPatch :: Ord key => Patch key value -> SingletonReplayArena key value +singletonArenaFromPatch patch = + case singletonPatchRow patch of + Just (key, before, after) -> + SingletonArenaAscending key [(key, (before, after))] + Nothing -> + SingletonArenaMap (arenaFromPatch patch) +{-# INLINABLE singletonArenaFromPatch #-} + +applySingletonReplayArena :: Ord key => SingletonReplayArena key value -> Map key value -> Map key value +applySingletonReplayArena arena initialState = + case arena of + SingletonArenaAscending _ rows -> + applyArenaBulkChanges (ascendingSingletonArenaBulkChanges rows) initialState + SingletonArenaMap entries -> + applyArenaDirect entries initialState +{-# INLINABLE applySingletonReplayArena #-} + + +ascendingSingletonArenaBulkChanges :: [(key, (Maybe value, Maybe value))] -> ArenaBulkChanges key value +ascendingSingletonArenaBulkChanges rows = + let !(AscendingArenaRows insertionRows deletionRows) = + Foldable.foldl' collectRow (AscendingArenaRows [] []) rows + !insertions = Map.fromDistinctAscList insertionRows + !deletions = Map.fromDistinctAscList deletionRows + in case (Map.null insertions, Map.null deletions) of + (True, True) -> + ArenaNoChanges + (False, True) -> + ArenaInsertions insertions + (True, False) -> + ArenaDeletions deletions + (False, False) -> + ArenaMixedChanges insertions deletions + where + collectRow :: + AscendingArenaRows key value -> + (key, (Maybe value, Maybe value)) -> + AscendingArenaRows key value + collectRow (AscendingArenaRows insertions deletions) (key, (_initial, current)) = + case current of + Nothing -> + AscendingArenaRows insertions ((key, ()) : deletions) + Just value -> + AscendingArenaRows ((key, value) : insertions) deletions +{-# INLINABLE ascendingSingletonArenaBulkChanges #-} + + +applyArenaBulkChanges :: Ord key => ArenaBulkChanges key value -> Map key value -> Map key value +applyArenaBulkChanges changes initialState = + case changes of + ArenaNoChanges -> + initialState + ArenaInsertions insertions -> + Map.union insertions initialState + ArenaDeletions deletions -> + Map.difference initialState deletions + ArenaMixedChanges insertions deletions -> + Map.union insertions (Map.difference initialState deletions) +{-# INLINABLE applyArenaBulkChanges #-} + +applySingletonToReplayArena :: + (Ord key, Eq value) => + Natural -> + key -> + Maybe value -> + Maybe value -> + StateProbe key value -> + SingletonReplayArena key value -> + Either (ReplayError key value) (StateProbe key value, SingletonReplayArena key value) +applySingletonToReplayArena patchIndex key expectedBefore currentAfter probe arena = + case arena of + SingletonArenaAscending latestKey rows + | latestKey < key -> + let (!initialBefore, !nextProbe) = probeInitialState key probe + in if expectedBefore == initialBefore + then + Right + ( nextProbe, + SingletonArenaAscending key ((key, (initialBefore, currentAfter)) : rows) + ) + else + Left + ReplayApplyError + { replayIndex = patchIndex, + replayApply = + ApplyBeforeMismatch + { mismatchKey = key, + expectedBefore = expectedBefore, + actualBefore = initialBefore + } + } + | otherwise -> + promote (Map.fromDistinctAscList (reverse rows)) + SingletonArenaMap entries -> + promote entries + where + promote entries = do + (!nextProbe, !nextEntries) <- applySingletonToArena patchIndex key expectedBefore currentAfter probe entries + pure (nextProbe, SingletonArenaMap nextEntries) +{-# INLINABLE applySingletonToReplayArena #-} + +singletonPatchRow :: Patch key value -> Maybe (key, Maybe value, Maybe value) +singletonPatchRow patch + | entryCount patch /= 1 = + Nothing + | otherwise = + case patch of + SmallPatch cells -> + case indexSmallArray cells 0 of + Cell key cell -> + Just (key, cellBefore cell, cellAfter cell) + PagedPatch _count pages -> + case pages of + MapInternal.Bin _ key page MapInternal.Tip MapInternal.Tip + | pageCount page == 1 -> + Just + ( key, + singletonEndpointMaybe (pageBeforeColumn page), + singletonEndpointMaybe (pageAfterColumn page) + ) + _ -> + Nothing +{-# INLINE singletonPatchRow #-} + +singletonEndpointMaybe :: EndpointColumn value -> Maybe value +singletonEndpointMaybe column = + case column of + AllPresent values -> + Just (valueColumnAt values 0) + Presence mask values -> + if testBit mask 0 + then Just (valueColumnAt values 0) + else Nothing +{-# INLINE singletonEndpointMaybe #-} + +applySingletonToArena :: + (Ord key, Eq value) => + Natural -> + key -> + Maybe value -> + Maybe value -> + StateProbe key value -> + Map key (Maybe value, Maybe value) -> + Either (ReplayError key value) (StateProbe key value, Map key (Maybe value, Maybe value)) +applySingletonToArena patchIndex key expectedBefore currentAfter probe = + descend + where + descend entries = + case entries of + MapInternal.Tip -> + let (!initialBefore, !nextProbe) = probeInitialState key probe + in validate initialBefore nextProbe (Map.singleton key (initialBefore, currentAfter)) + MapInternal.Bin nodeSize existingKey existingEntry left right -> + case compare key existingKey of + LT -> do + (!nextProbe, !updatedLeft) <- descend left + pure (nextProbe, MapInternal.link existingKey existingEntry updatedLeft right) + GT -> do + (!nextProbe, !updatedRight) <- descend right + pure (nextProbe, MapInternal.link existingKey existingEntry left updatedRight) + EQ -> + let (!initialBefore, !actualBefore) = existingEntry + in validate + actualBefore + probe + (MapInternal.Bin nodeSize key (initialBefore, currentAfter) left right) + + validate actualBefore nextProbe updatedArena + | expectedBefore == actualBefore = + Right (nextProbe, updatedArena) + | otherwise = + Left + ReplayApplyError + { replayIndex = patchIndex, + replayApply = + ApplyBeforeMismatch + { mismatchKey = key, + expectedBefore = expectedBefore, + actualBefore = actualBefore + } + } +{-# INLINABLE applySingletonToArena #-} + +useSequentialReplay :: Patch key patch -> Patch key patch -> Bool +useSequentialReplay accumulated nextPatch = + entryCount accumulated == 1 + && entryCount nextPatch == 1 +{-# INLINE useSequentialReplay #-} + +useReplayArena :: Coverage -> Patch key value -> Patch key value -> Bool +useReplayArena coverage accumulated nextPatch = + coverageOlderOnly coverage + && not (coverageNewerOnly coverage) + && entryCount nextPatch <= entryCount accumulated `div` sparseSubsetReplayFactor +{-# INLINE useReplayArena #-} + +sparseSubsetReplayFactor :: Int +sparseSubsetReplayFactor = 4 +{-# INLINE sparseSubsetReplayFactor #-} + +arenaFromPatch :: Ord key => Patch key value -> Map key (Maybe value, Maybe value) +arenaFromPatch = + foldPatchRows + ( \arena key initial current -> + insertArenaEntry key (initial, current) arena + ) + Map.empty +{-# INLINABLE arenaFromPatch #-} + +applyPatchToArena :: + forall key value. + (Ord key, Eq value) => + Natural -> + Map key value -> + Patch key value -> + Map key (Maybe value, Maybe value) -> + Either (ReplayError key value) (Map key (Maybe value, Maybe value)) +applyPatchToArena patchIndex initialState patch initialArena = + case patch of + SmallPatch cells -> + goSmall cells 0 initialArena + PagedPatch _count pages -> + go initialArena (cursor pages) + where + go !arena CursorEnd = + Right arena + go !arena cursor = + case currentKey cursor of + Nothing -> + Right arena + Just key -> + case stepArena key (beforeMaybe cursor) (afterMaybe cursor) arena of + Left failure -> + Left failure + Right nextArena -> + go nextArena (advanceRow cursor) + + goSmall cells !index !arena + | index == sizeofSmallArray cells = + Right arena + | otherwise = + case indexSmallArray cells index of + Cell key cell -> + case stepArena key (cellBefore cell) (cellAfter cell) arena of + Left failure -> + Left failure + Right nextArena -> + goSmall cells (index + 1) nextArena + + stepArena !key !expected !currentAfter !arena = + let (!initialBefore, !actualBefore) = + case Map.lookup key arena of + Just (initial, current) -> + (initial, current) + Nothing -> + let !initial = Map.lookup key initialState + in (initial, initial) + in if expected == actualBefore + then Right (insertArenaEntry key (initialBefore, currentAfter) arena) + else + Left + ReplayApplyError + { replayIndex = patchIndex, + replayApply = + ApplyBeforeMismatch + { mismatchKey = key, + expectedBefore = expected, + actualBefore = actualBefore + } + } +{-# INLINABLE applyPatchToArena #-} + +insertArenaEntry :: Ord key => key -> (Maybe value, Maybe value) -> Map key (Maybe value, Maybe value) -> Map key (Maybe value, Maybe value) +insertArenaEntry patchKey entry = + descend + where + descend entries = + case entries of + MapInternal.Tip -> + Map.singleton patchKey entry + MapInternal.Bin nodeSize existingKey existingEntry left right -> + case compare patchKey existingKey of + LT -> + MapInternal.link existingKey existingEntry (descend left) right + GT -> + MapInternal.link existingKey existingEntry left (descend right) + EQ -> + MapInternal.Bin nodeSize patchKey entry left right +{-# INLINABLE insertArenaEntry #-} + +applyArenaDirect :: Ord key => Map key (Maybe value, Maybe value) -> Map key value -> Map key value +applyArenaDirect arena initialState + | useArenaPointwiseFinalization arena initialState = + applyArenaPointwise arena initialState + | useArenaBulkFinalization arena initialState = + applyArenaBulk arena initialState + | otherwise = + case replayOutputCountCandidate arena initialState of + Nothing -> + applyArenaBulk arena initialState + Just outputCount -> + case buildReplayMap outputCount initialCursor of + Just (BuildReplayResult result remaining) + | drainReplayCursor remaining -> + result + _ -> + applyArenaBulk arena initialState + where + !initialCursor = + ReplayMergeCursor (ascCursor initialState) (ascCursor arena) +{-# INLINABLE applyArenaDirect #-} + +useArenaPointwiseFinalization :: Map key patch -> Map key value -> Bool +useArenaPointwiseFinalization arena initialState = + Map.size arena <= pageCapacity + && shouldUseSparse (Map.size initialState) (Map.size arena) +{-# INLINE useArenaPointwiseFinalization #-} + +useArenaBulkFinalization :: Map key patch -> Map key value -> Bool +useArenaBulkFinalization arena initialState = + shouldUseSparse (Map.size initialState) (Map.size arena) +{-# INLINE useArenaBulkFinalization #-} + +replayOutputCountCandidate :: Map key (Maybe value, Maybe value) -> Map key value -> Maybe Int +replayOutputCountCandidate arena initialState = + let !outputCount = Map.size initialState + arenaNetSizeDelta arena + in if outputCount < 0 then Nothing else Just outputCount +{-# INLINE replayOutputCountCandidate #-} + +arenaNetSizeDelta :: Map key (Maybe value, Maybe value) -> Int +arenaNetSizeDelta = + Map.foldl' addEntry 0 + where + addEntry :: Int -> (Maybe value, Maybe value) -> Int + addEntry !total entry = + total + arenaEntryNetSizeDelta entry +{-# INLINE arenaNetSizeDelta #-} + +arenaEntryNetSizeDelta :: (Maybe value, Maybe value) -> Int +arenaEntryNetSizeDelta endpoints = + case endpoints of + (Nothing, Just _) -> + 1 + (Just _, Nothing) -> + -1 + _ -> + 0 +{-# INLINE arenaEntryNetSizeDelta #-} + +drainReplayCursor :: Ord key => ReplayMergeCursor key value -> Bool +drainReplayCursor cursor = + case nextReplayOutput cursor of + Nothing -> + True + Just _ -> + False +{-# INLINABLE drainReplayCursor #-} + +buildReplayMap :: Ord key => Int -> ReplayMergeCursor key value -> Maybe (BuildReplayResult key value) +buildReplayMap !outputCount cursor + | outputCount <= 0 = + Just (BuildReplayResult MapInternal.Tip cursor) + | otherwise = do + let !leftCount = outputCount `quot` 2 + !rightCount = outputCount - leftCount - 1 + BuildReplayResult left afterLeft <- buildReplayMap leftCount cursor + ReplayOutput key value afterMiddle <- nextReplayOutput afterLeft + BuildReplayResult right afterRight <- buildReplayMap rightCount afterMiddle + Just (BuildReplayResult (MapInternal.Bin outputCount key value left right) afterRight) +{-# INLINABLE buildReplayMap #-} + +nextReplayOutput :: forall key value. Ord key => ReplayMergeCursor key value -> Maybe (ReplayOutput key value) +nextReplayOutput (ReplayMergeCursor stateCursor arenaCursor) = + case (stateCursor, arenaCursor) of + (AscEnd, AscEnd) -> + Nothing + (AscCursor stateKey stateValue _ _, AscEnd) -> + Just (ReplayOutput stateKey stateValue (ReplayMergeCursor (ascAdvance stateCursor) AscEnd)) + (AscEnd, AscCursor arenaKey (_initial, current) _ _) -> + emitArenaCurrent arenaKey current (ReplayMergeCursor AscEnd (ascAdvance arenaCursor)) + (AscCursor stateKey stateValue _ _, AscCursor arenaKey (_initial, current) _ _) -> + case compare stateKey arenaKey of + LT -> + Just (ReplayOutput stateKey stateValue (ReplayMergeCursor (ascAdvance stateCursor) arenaCursor)) + GT -> + emitArenaCurrent arenaKey current (ReplayMergeCursor stateCursor (ascAdvance arenaCursor)) + EQ -> + emitArenaCurrent arenaKey current (ReplayMergeCursor (ascAdvance stateCursor) (ascAdvance arenaCursor)) + where + emitArenaCurrent :: key -> Maybe value -> ReplayMergeCursor key value -> Maybe (ReplayOutput key value) + emitArenaCurrent key current nextCursor = + case current of + Nothing -> + nextReplayOutput nextCursor + Just value -> + Just (ReplayOutput key value nextCursor) +{-# INLINABLE nextReplayOutput #-} + +applyArenaPointwise :: forall key value. Ord key => Map key (Maybe value, Maybe value) -> Map key value -> Map key value +applyArenaPointwise arena initialState = + Map.foldlWithKey' applyArenaEntry initialState arena + where + applyArenaEntry :: Map key value -> key -> (Maybe value, Maybe value) -> Map key value + applyArenaEntry state key (_initial, current) = + applyTrustedEdit key current state +{-# INLINABLE applyArenaPointwise #-} + +applyArenaBulk :: Ord key => Map key (Maybe value, Maybe value) -> Map key value -> Map key value +applyArenaBulk arena initialState = + let !insertions = Map.mapMaybe arenaCurrentPresent arena + !deletions = Map.mapMaybe arenaCurrentAbsent arena + in Map.union insertions (Map.difference initialState deletions) + where + arenaCurrentPresent :: (Maybe value, Maybe value) -> Maybe value + arenaCurrentPresent (_initial, current) = + current + + arenaCurrentAbsent :: (Maybe value, Maybe value) -> Maybe () + arenaCurrentAbsent (_initial, current) = + case current of + Nothing -> + Just () + Just _ -> + Nothing +{-# INLINABLE applyArenaBulk #-} + +foldPatchRows :: + (result -> key -> Maybe value -> Maybe value -> result) -> + result -> + Patch key value -> + result +foldPatchRows step initial patch = + case patch of + SmallPatch cells -> + goSmall initial cells 0 + PagedPatch _count pages -> + go initial (cursor pages) + where + go !result CursorEnd = + result + go !result cursor = + case currentKey cursor of + Nothing -> + result + Just key -> + go + (step result key (beforeMaybe cursor) (afterMaybe cursor)) + (advanceRow cursor) + + goSmall !result cells !index + | index == sizeofSmallArray cells = + result + | otherwise = + case indexSmallArray cells index of + Cell key cell -> + goSmall + (step result key (cellBefore cell) (cellAfter cell)) + cells + (index + 1) +{-# INLINABLE foldPatchRows #-} + +validateFirstTouches :: + forall key value. + (Ord key, Eq value) => + Natural -> + StateProbe key value -> + Patch key value -> + Either (ReplayError key value) (StateProbe key value) +validateFirstTouches patchIndex = + go + where + go !probe patch = + case patch of + SmallPatch cells -> + scanSmall probe cells 0 + PagedPatch _count pages -> + scan probe (cursor pages) + + scan !probe CursorEnd = + Right probe + scan !probe cursor = + case currentKey cursor of + Nothing -> + Right probe + Just key -> + case validateInitialBefore patchIndex probe key (beforeMaybe cursor) of + Left failure -> + Left failure + Right nextProbe -> + scan nextProbe (advanceRow cursor) + + scanSmall !probe cells !index + | index == sizeofSmallArray cells = + Right probe + | otherwise = + case indexSmallArray cells index of + Cell key cell -> + case validateInitialBefore patchIndex probe key (cellBefore cell) of + Left failure -> + Left failure + Right nextProbe -> + scanSmall nextProbe cells (index + 1) +{-# INLINABLE validateFirstTouches #-} + +validateInitialBefore :: + forall key value. + (Ord key, Eq value) => + Natural -> + StateProbe key value -> + key -> + Maybe value -> + Either (ReplayError key value) (StateProbe key value) +validateInitialBefore patchIndex probe key expected = + let (!actual, !nextProbe) = probeInitialState key probe + in if expected == actual + then Right nextProbe + else + Left + ReplayApplyError + { replayIndex = patchIndex, + replayApply = + ApplyBeforeMismatch + { mismatchKey = key, + expectedBefore = expected, + actualBefore = actual + } + } +{-# INLINABLE validateInitialBefore #-} + +replayBoundaryError :: Natural -> key -> Maybe value -> Maybe value -> ReplayError key value +replayBoundaryError patchIndex key olderAfter newerBefore = + ReplayApplyError + { replayIndex = patchIndex, + replayApply = + ApplyBeforeMismatch + { mismatchKey = key, + expectedBefore = newerBefore, + actualBefore = olderAfter + } + } +{-# INLINE replayBoundaryError #-} diff --git a/src-patch/Moonlight/Delta/Patch/Internal/Types.hs b/src-patch/Moonlight/Delta/Patch/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src-patch/Moonlight/Delta/Patch/Internal/Types.hs @@ -0,0 +1,779 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Moonlight.Delta.Patch.Internal.Types + ( CellPatch (..), + Cell (..), + Endpoint (..), + PatchKey, + PatchValue, + buildKeyColumn, + KeyColumn (..), + ValueRun (..), + ValueColumn (..), + EndpointColumn (..), + Page (..), + Patch (..), + ApplyError (..), + ComposeError (..), + ReplayError (..), + BoundaryResult (..), + CodecStats (..), + pageCapacity, + smallFormThreshold, + entryCount, + pagesOf, + smallCellsToAscList, + cellsForInstance, + normalize, + null, + size, + netSizeDelta, + support, + keyColumnAt, + keyColumnCount, + valueColumnAt, + valueColumnFromArray, + debugCodecStats, + pageKeyAt, + ) +where + +import Data.Bits + ( Bits ((.&.), popCount, shiftL, testBit), + FiniteBits (finiteBitSize), + ) +import Data.Kind (Constraint, Type) +import Data.List qualified as List +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Proxy (Proxy (..)) +import Data.Primitive.SmallArray + ( SmallArray, + emptySmallArray, + indexSmallArray, + smallArrayFromList, + sizeofSmallArray, + ) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Word (Word64) +import Moonlight.Delta.Normalize + ( DeltaNormalize (..), + ) +import Moonlight.Delta.Support + ( DeltaSupport (..), + ) +import Numeric.Natural (Natural) +import Prelude hiding (null) + +pageCapacity :: Int +pageCapacity = + finiteBitSize (0 :: Word64) +{-# INLINE pageCapacity #-} + +type CellPatch :: Type -> Type +data CellPatch value + = AssertAbsent + | Insert !value + | Delete !value + | Replace !value !value + deriving stock (Eq, Ord, Show) + +type Cell :: Type -> Type -> Type +data Cell key value = Cell !key !(CellPatch value) + deriving stock (Eq, Ord, Show) + +type Endpoint :: Type -> Type +data Endpoint value + = EndpointAbsent + | EndpointPresent !value + deriving stock (Eq, Ord, Show) + +type KeyColumn :: Type -> Type +data KeyColumn key where + ExplicitKeys :: !(SmallArray key) -> KeyColumn key + IntRangeKeys :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> KeyColumn Int + IntAffineKeys :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> KeyColumn Int + +instance Eq key => Eq (KeyColumn key) where + left == right = + keyColumnToList left == keyColumnToList right + {-# INLINE (==) #-} + +instance Ord key => Ord (KeyColumn key) where + compare left right = + compare (keyColumnToList left) (keyColumnToList right) + {-# INLINE compare #-} + +instance Show key => Show (KeyColumn key) where + showsPrec precedence column = + showParen + (precedence > 10) + ( showString "KeyColumn " + . shows (keyColumnToList column) + ) + +type PatchRepresentation :: Type +data PatchRepresentation + = GenericPatchRepresentation + | IntPatchRepresentation + +type PatchRepresentationOf :: Type -> PatchRepresentation +type family PatchRepresentationOf value where + PatchRepresentationOf Int = 'IntPatchRepresentation + PatchRepresentationOf _value = 'GenericPatchRepresentation + +type PatchKeyColumnBuilder :: PatchRepresentation -> Type -> Constraint +class Ord key => PatchKeyColumnBuilder representation key where + buildSelectedKeyColumn :: Proxy representation -> SmallArray key -> KeyColumn key + +instance Ord key => PatchKeyColumnBuilder 'GenericPatchRepresentation key where + buildSelectedKeyColumn _representation = + ExplicitKeys + {-# INLINE buildSelectedKeyColumn #-} + +instance PatchKeyColumnBuilder 'IntPatchRepresentation Int where + buildSelectedKeyColumn _representation keys = + case sizeofSmallArray keys of + 0 -> + ExplicitKeys keys + 1 -> + IntRangeKeys (indexSmallArray keys 0) 1 + count -> + let !start = indexSmallArray keys 0 + !step = indexSmallArray keys 1 - start + in if intKeysAreAffine keys start step count 2 + then + if step == 1 + then IntRangeKeys start count + else IntAffineKeys start step count + else ExplicitKeys keys + {-# INLINE buildSelectedKeyColumn #-} + +type PatchKey :: Type -> Constraint +type PatchKey key = PatchKeyColumnBuilder (PatchRepresentationOf key) key + +buildKeyColumn :: forall key. PatchKey key => SmallArray key -> KeyColumn key +buildKeyColumn = + buildSelectedKeyColumn (Proxy @(PatchRepresentationOf key)) +{-# INLINE buildKeyColumn #-} + +type ValueRun :: Type -> Type +data ValueRun value = ValueRun {-# UNPACK #-} !Int !value + deriving stock (Eq, Ord, Show) + +type ValueColumn :: Type -> Type +data ValueColumn value where + ConstantValues :: {-# UNPACK #-} !Int -> !value -> ValueColumn value + RunValues :: {-# UNPACK #-} !Int -> !(SmallArray (ValueRun value)) -> ValueColumn value + DenseValues :: !(SmallArray value) -> ValueColumn value + IntAffineValues :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> ValueColumn Int + +instance Eq value => Eq (ValueColumn value) where + left == right = + valueColumnToList left == valueColumnToList right + {-# INLINE (==) #-} + +instance Ord value => Ord (ValueColumn value) where + compare left right = + compare (valueColumnToList left) (valueColumnToList right) + {-# INLINE compare #-} + +instance Show value => Show (ValueColumn value) where + showsPrec precedence column = + showParen + (precedence > 10) + ( showString "ValueColumn " + . shows (valueColumnToList column) + ) + +type PatchValueColumnBuilder :: PatchRepresentation -> Type -> Constraint +class Eq value => PatchValueColumnBuilder representation value where + buildSelectedValueColumn :: Proxy representation -> SmallArray value -> ValueColumn value + +instance Eq value => PatchValueColumnBuilder 'GenericPatchRepresentation value where + buildSelectedValueColumn _representation = + buildGenericValueColumn + {-# INLINE buildSelectedValueColumn #-} + +instance PatchValueColumnBuilder 'IntPatchRepresentation Int where + buildSelectedValueColumn _representation = + buildIntValueColumn + {-# INLINE buildSelectedValueColumn #-} + +type PatchValue :: Type -> Constraint +type PatchValue value = PatchValueColumnBuilder (PatchRepresentationOf value) value + +buildValueColumn :: forall value. PatchValue value => SmallArray value -> ValueColumn value +buildValueColumn = + buildSelectedValueColumn (Proxy @(PatchRepresentationOf value)) +{-# INLINE buildValueColumn #-} + +type EndpointColumn :: Type -> Type +data EndpointColumn value + = AllPresent !(ValueColumn value) + | Presence {-# UNPACK #-} !Word64 !(ValueColumn value) + deriving stock (Eq, Ord, Show) + +type Page :: Type -> Type -> Type +data Page key value = Page + { pageCount :: {-# UNPACK #-} !Int, + pagePrefixKeys :: !(KeyColumn key), + pageBeforeColumn :: !(EndpointColumn value), + pageAfterColumn :: !(EndpointColumn value) + } + deriving stock (Eq, Ord, Show) + +type Patch :: Type -> Type -> Type +data Patch key value + = SmallPatch !(SmallArray (Cell key value)) + | PagedPatch {-# UNPACK #-} !Int !(Map key (Page key value)) + +smallFormThreshold :: Int +smallFormThreshold = + 16 +{-# INLINE smallFormThreshold #-} + +entryCount :: Patch key value -> Int +entryCount patch = + case patch of + SmallPatch cells -> + sizeofSmallArray cells + PagedPatch count _pages -> + count +{-# INLINE entryCount #-} + +pagesOf :: Patch key value -> Map key (Page key value) +pagesOf patch = + case patch of + PagedPatch _count pages -> + pages + SmallPatch _cells -> + Map.empty +{-# INLINE pagesOf #-} + +instance (Eq key, Eq value) => Eq (Patch key value) where + left == right = + cellsForInstance left == cellsForInstance right + {-# INLINE (==) #-} + +instance (Ord key, Ord value) => Ord (Patch key value) where + compare left right = + compare (cellsForInstance left) (cellsForInstance right) + {-# INLINE compare #-} + +instance (Show key, Show value) => Show (Patch key value) where + showsPrec precedence patch = + showParen + (precedence > 10) + ( showString "Patch " + . shows (cellsForInstance patch) + ) + + +type ApplyError :: Type -> Type -> Type +data ApplyError key value = ApplyBeforeMismatch + { mismatchKey :: !key, + expectedBefore :: !(Maybe value), + actualBefore :: !(Maybe value) + } + deriving stock (Eq, Ord, Show) + +type ComposeError :: Type -> Type -> Type +data ComposeError key value = ComposeBoundaryMismatch + { boundaryKey :: !key, + olderAfter :: !(Maybe value), + newerBefore :: !(Maybe value) + } + deriving stock (Eq, Ord, Show) + +type ReplayError :: Type -> Type -> Type +data ReplayError key value = ReplayApplyError + { replayIndex :: !Natural, + replayApply :: !(ApplyError key value) + } + deriving stock (Eq, Ord, Show) + +type BoundaryResult :: Type -> Type +data BoundaryResult error + = PageBoundaryMatched + | PageBoundaryDiverged + | PageBoundaryRejected !error + +data CodecStats = CodecStats + { codecExplicitKeyColumns :: {-# UNPACK #-} !Int, + codecRangeKeyColumns :: {-# UNPACK #-} !Int, + codecAffineKeyColumns :: {-# UNPACK #-} !Int, + codecAbsentColumns :: {-# UNPACK #-} !Int, + codecConstantColumns :: {-# UNPACK #-} !Int, + codecRunColumns :: {-# UNPACK #-} !Int, + codecAffineValueColumns :: {-# UNPACK #-} !Int, + codecDenseColumns :: {-# UNPACK #-} !Int + } + deriving stock (Eq, Show) + +normalize :: Patch key value -> Patch key value +normalize patchValue = + case patchValue of + SmallPatch _cells -> + patchValue + PagedPatch count _pages + | count < smallFormThreshold -> + SmallPatch + ( smallArrayFromList + [ Cell key cell + | (key, cell) <- cellsForInstance patchValue + ] + ) + | otherwise -> + patchValue +{-# INLINE normalize #-} + +null :: Patch key value -> Bool +null patch = + entryCount patch == 0 +{-# INLINE null #-} + +size :: Patch key value -> Int +size = + entryCount +{-# INLINE size #-} + +netSizeDelta :: Patch key value -> Int +netSizeDelta patch = + case patch of + SmallPatch cells -> + smallCellsNetSizeDelta cells 0 0 + PagedPatch _count pages -> + Map.foldlWithKey' addPage 0 pages + where + addPage :: Int -> key -> Page key value -> Int + addPage !total _maximumKey page = + total + pageNetSizeDelta page +{-# INLINE netSizeDelta #-} + +smallCellsNetSizeDelta :: SmallArray (Cell key value) -> Int -> Int -> Int +smallCellsNetSizeDelta cells !index !total + | index == sizeofSmallArray cells = + total + | otherwise = + let Cell _key cell = indexSmallArray cells index + in smallCellsNetSizeDelta cells (index + 1) (total + cellNetSizeDelta cell) + +cellNetSizeDelta :: CellPatch value -> Int +cellNetSizeDelta cell = + case cell of + AssertAbsent -> + 0 + Insert _new -> + 1 + Delete _old -> + -1 + Replace _old _new -> + 0 +{-# INLINE cellNetSizeDelta #-} + +smallCellsToAscList :: SmallArray (Cell key value) -> [(key, CellPatch value)] +smallCellsToAscList cells = + go (sizeofSmallArray cells - 1) [] + where + go index rest + | index < 0 = + rest + | otherwise = + let Cell key cell = indexSmallArray cells index + in go (index - 1) ((key, cell) : rest) + +pageNetSizeDelta :: Page key value -> Int +pageNetSizeDelta page = + endpointColumnPresentCount count (pageAfterColumn page) + - endpointColumnPresentCount count (pageBeforeColumn page) + where + !count = pageCount page +{-# INLINE pageNetSizeDelta #-} + +endpointColumnPresentCount :: Int -> EndpointColumn value -> Int +endpointColumnPresentCount count = + popCount . columnPresenceMaskLocal count +{-# INLINE endpointColumnPresentCount #-} + +debugCodecStats :: Patch key value -> CodecStats +debugCodecStats patch = + case patch of + SmallPatch _cells -> + emptyCodecStats + PagedPatch _count pages -> + Map.foldl' countPage emptyCodecStats pages + where + countPage :: CodecStats -> Page key value -> CodecStats + countPage stats page = + countEndpointColumn + (pageAfterColumn page) + (countEndpointColumn (pageBeforeColumn page) (countKeyColumn (pagePrefixKeys page) stats)) +{-# INLINABLE debugCodecStats #-} + +emptyCodecStats :: CodecStats +emptyCodecStats = + CodecStats + { codecExplicitKeyColumns = 0, + codecRangeKeyColumns = 0, + codecAffineKeyColumns = 0, + codecAbsentColumns = 0, + codecConstantColumns = 0, + codecRunColumns = 0, + codecAffineValueColumns = 0, + codecDenseColumns = 0 + } +{-# INLINE emptyCodecStats #-} + +countKeyColumn :: KeyColumn key -> CodecStats -> CodecStats +countKeyColumn column stats = + case column of + ExplicitKeys _keys -> + stats {codecExplicitKeyColumns = codecExplicitKeyColumns stats + 1} + IntRangeKeys {} -> + stats {codecRangeKeyColumns = codecRangeKeyColumns stats + 1} + IntAffineKeys {} -> + stats {codecAffineKeyColumns = codecAffineKeyColumns stats + 1} +{-# INLINE countKeyColumn #-} + +countEndpointColumn :: EndpointColumn value -> CodecStats -> CodecStats +countEndpointColumn column stats = + case column of + AllPresent values -> + countValueColumn values stats + Presence mask values + | mask == 0 -> + stats {codecAbsentColumns = codecAbsentColumns stats + 1} + | otherwise -> + countValueColumn values stats +{-# INLINE countEndpointColumn #-} + +countValueColumn :: ValueColumn value -> CodecStats -> CodecStats +countValueColumn values stats = + case values of + ConstantValues {} -> + stats {codecConstantColumns = codecConstantColumns stats + 1} + RunValues {} -> + stats {codecRunColumns = codecRunColumns stats + 1} + IntAffineValues {} -> + stats {codecAffineValueColumns = codecAffineValueColumns stats + 1} + DenseValues {} -> + stats {codecDenseColumns = codecDenseColumns stats + 1} +{-# INLINE countValueColumn #-} + +support :: forall key value. Patch key value -> Set key +support patch = + case patch of + SmallPatch cells -> + Set.fromDistinctAscList (fmap fst (smallCellsToAscList cells)) + PagedPatch _count pages -> + Set.fromDistinctAscList (Map.foldrWithKey prependPage [] pages) + where + prependPage :: key -> Page key value -> [key] -> [key] + prependPage maximumKey page rest = + prependPrefix (pageCount page - 2) (maximumKey : rest) + where + prependPrefix index accumulated + | index < 0 = + accumulated + | otherwise = + prependPrefix + (index - 1) + (keyColumnAt (pagePrefixKeys page) index : accumulated) +{-# INLINE support #-} + +pageKeyAt :: key -> Page key value -> Int -> key +pageKeyAt maximumKey page index = + if index == pageCount page - 1 + then maximumKey + else keyColumnAt (pagePrefixKeys page) index +{-# INLINE pageKeyAt #-} + +keyColumnAt :: KeyColumn key -> Int -> key +keyColumnAt column index = + case column of + ExplicitKeys keys -> + indexSmallArray keys index + IntRangeKeys start _count -> + start + index + IntAffineKeys start step _count -> + start + index * step +{-# INLINE keyColumnAt #-} + +keyColumnCount :: KeyColumn key -> Int +keyColumnCount column = + case column of + ExplicitKeys keys -> + sizeofSmallArray keys + IntRangeKeys _start count -> + count + IntAffineKeys _start _step count -> + count +{-# INLINE keyColumnCount #-} + +keyColumnToList :: KeyColumn key -> [key] +keyColumnToList column = + collect 0 + where + !count = keyColumnCount column + + collect !index + | index == count = + [] + | otherwise = + keyColumnAt column index : collect (index + 1) +{-# INLINE keyColumnToList #-} + +intKeysAreAffine :: SmallArray Int -> Int -> Int -> Int -> Int -> Bool +intKeysAreAffine keys !start !step !count !index + | index == count = + True + | indexSmallArray keys index == start + index * step = + intKeysAreAffine keys start step count (index + 1) + | otherwise = + False +{-# INLINE intKeysAreAffine #-} + +valueColumnAt :: ValueColumn value -> Int -> value +valueColumnAt column index = + case column of + ConstantValues _count value -> + value + RunValues _count runs -> + runValueAt index 0 runs + DenseValues values -> + indexSmallArray values index + IntAffineValues start step _count -> + start + index * step +{-# INLINE valueColumnAt #-} + +valueColumnCount :: ValueColumn value -> Int +valueColumnCount column = + case column of + ConstantValues count _value -> + count + RunValues count _runs -> + count + DenseValues values -> + sizeofSmallArray values + IntAffineValues _start _step count -> + count +{-# INLINE valueColumnCount #-} + +valueColumnFromArray :: PatchValue value => SmallArray value -> ValueColumn value +valueColumnFromArray = + buildValueColumn +{-# INLINE valueColumnFromArray #-} + +valueColumnToList :: ValueColumn value -> [value] +valueColumnToList column = + collect 0 + where + !count = valueColumnCount column + + collect !index + | index == count = + [] + | otherwise = + valueColumnAt column index : collect (index + 1) +{-# INLINE valueColumnToList #-} + +buildGenericValueColumn :: Eq value => SmallArray value -> ValueColumn value +buildGenericValueColumn values = + case sizeofSmallArray values of + 0 -> + DenseValues emptySmallArray + count -> + let !firstValue = indexSmallArray values 0 + !runs = valueRunsFromArray values count firstValue 1 1 [] + in case runs of + [ValueRun _runLength value] -> + ConstantValues count value + _ -> + if runEncodingIsSmaller count (List.length runs) + then RunValues count (smallArrayFromList runs) + else DenseValues values +{-# INLINABLE buildGenericValueColumn #-} + +buildIntValueColumn :: SmallArray Int -> ValueColumn Int +buildIntValueColumn values = + case sizeofSmallArray values of + 0 -> + DenseValues emptySmallArray + 1 -> + ConstantValues 1 (indexSmallArray values 0) + count -> + let !start = indexSmallArray values 0 + !step = indexSmallArray values 1 - start + in if intValuesAreAffine values start step count 2 + then + if step == 0 + then ConstantValues count start + else IntAffineValues start step count + else buildGenericValueColumn values +{-# INLINABLE buildIntValueColumn #-} + +intValuesAreAffine :: SmallArray Int -> Int -> Int -> Int -> Int -> Bool +intValuesAreAffine values !start !step !count !index + | index == count = + True + | indexSmallArray values index == start + index * step = + intValuesAreAffine values start step count (index + 1) + | otherwise = + False +{-# INLINE intValuesAreAffine #-} + +valueRunsFromArray :: Eq value => SmallArray value -> Int -> value -> Int -> Int -> [ValueRun value] -> [ValueRun value] +valueRunsFromArray values !count current !currentLength !index reversedRuns + | index == count = + List.reverse (ValueRun currentLength current : reversedRuns) + | otherwise = + let !next = indexSmallArray values index + in if current == next + then valueRunsFromArray values count current (currentLength + 1) (index + 1) reversedRuns + else valueRunsFromArray values count next 1 (index + 1) (ValueRun currentLength current : reversedRuns) +{-# INLINABLE valueRunsFromArray #-} + +runEncodingIsSmaller :: Int -> Int -> Bool +runEncodingIsSmaller denseCount runCount = + runCount * runEncodingCellWeight < denseCount +{-# INLINE runEncodingIsSmaller #-} + +runEncodingCellWeight :: Int +runEncodingCellWeight = + 2 +{-# INLINE runEncodingCellWeight #-} + +runValueAt :: Int -> Int -> SmallArray (ValueRun value) -> value +runValueAt index runIndex runs = + case indexSmallArray runs runIndex of + ValueRun runLength value + | index < runLength -> + value + | otherwise -> + runValueAt (index - runLength) (runIndex + 1) runs +{-# INLINE runValueAt #-} + +cellsForInstance :: forall key value. Patch key value -> [(key, CellPatch value)] +cellsForInstance patch = + case patch of + SmallPatch cells -> + smallCellsToAscList cells + PagedPatch _count pages -> + Map.foldrWithKey collectPage [] pages + where + collectPage :: key -> Page key value -> [(key, CellPatch value)] -> [(key, CellPatch value)] + collectPage maximumKey page rest = + let !count = pageCount page + !beforeMask = columnPresenceMaskLocal count (pageBeforeColumn page) + !beforeValues = columnValuesLocal (pageBeforeColumn page) + !afterMask = columnPresenceMaskLocal count (pageAfterColumn page) + !afterValues = columnValuesLocal (pageAfterColumn page) + in collectPageCells maximumKey page beforeMask beforeValues afterMask afterValues 0 0 0 rest +{-# INLINE cellsForInstance #-} + +collectPageCells :: + key -> + Page key value -> + Word64 -> + ValueColumn value -> + Word64 -> + ValueColumn value -> + Int -> + Int -> + Int -> + [(key, CellPatch value)] -> + [(key, CellPatch value)] +collectPageCells maximumKey page beforeMask beforeValues afterMask afterValues index beforePacked afterPacked rest + | index == pageCount page = + rest + | otherwise = + let !key = pageKeyAt maximumKey page index + !beforePresent = testBit beforeMask index + !afterPresent = testBit afterMask index + !before = + if beforePresent + then EndpointPresent (valueColumnAt beforeValues beforePacked) + else EndpointAbsent + !after = + if afterPresent + then EndpointPresent (valueColumnAt afterValues afterPacked) + else EndpointAbsent + !nextBeforePacked = + if beforePresent + then beforePacked + 1 + else beforePacked + !nextAfterPacked = + if afterPresent + then afterPacked + 1 + else afterPacked + in (key, endpointsToCell before after) + : collectPageCells maximumKey page beforeMask beforeValues afterMask afterValues (index + 1) nextBeforePacked nextAfterPacked rest +{-# INLINE collectPageCells #-} + +columnPresenceMaskLocal :: Int -> EndpointColumn value -> Word64 +columnPresenceMaskLocal count column = + case column of + AllPresent _values -> + lowerBitsMaskLocal count + Presence presenceMask _values -> + presenceMask .&. lowerBitsMaskLocal count +{-# INLINE columnPresenceMaskLocal #-} + +columnValuesLocal :: EndpointColumn value -> ValueColumn value +columnValuesLocal column = + case column of + AllPresent values -> + values + Presence _presenceMask values -> + values +{-# INLINE columnValuesLocal #-} + +lowerBitsMaskLocal :: Int -> Word64 +lowerBitsMaskLocal count + | count <= 0 = + 0 + | count >= pageCapacity = + maxBound + | otherwise = + (1 `shiftL` count) - 1 +{-# INLINE lowerBitsMaskLocal #-} + +endpointsToCell :: Endpoint value -> Endpoint value -> CellPatch value +endpointsToCell before after = + case (before, after) of + (EndpointAbsent, EndpointAbsent) -> + AssertAbsent + (EndpointAbsent, EndpointPresent afterValue) -> + Insert afterValue + (EndpointPresent beforeValue, EndpointAbsent) -> + Delete beforeValue + (EndpointPresent beforeValue, EndpointPresent afterValue) -> + Replace beforeValue afterValue +{-# INLINE endpointsToCell #-} + +instance DeltaNormalize (Patch key value) where + normalizeDelta = + normalize + + deltaNull = + null + +instance DeltaSupport (Patch key value) where + type DeltaSupportSet (Patch key value) = Set key + + emptySupport = + Set.empty + + deltaSupport = + support diff --git a/src-repair/Moonlight/Delta/Repair.hs b/src-repair/Moonlight/Delta/Repair.hs new file mode 100644 --- /dev/null +++ b/src-repair/Moonlight/Delta/Repair.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Moonlight.Delta.Repair + ( Kernel (..), + Step (..), + Config (..), + Result (..), + Trace (..), + Round, + Correction (..), + boundedRepair, + boundedRepairTraced, + sequenceRepair, + productRepair, + focusRepair, + identityRepair, + mapRepair, + corrections, + obstructions, + applied, + appliedCorrections, + irreducible, + roundsUsed, + isConverged, + resultState, + ) +where + +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (maybeToList) +import Numeric.Natural (Natural) +import Prelude + +type Kernel :: Type -> Type -> Type -> Type +data Kernel state obstruction correction = Kernel + { check :: state -> Step state obstruction, + residuate :: obstruction -> Maybe correction, + applyKernelCorrection :: state -> correction -> state + } + +type Step :: Type -> Type -> Type +data Step state obstruction + = StepConverged state + | StepObstructed state (NonEmpty obstruction) + deriving stock (Eq, Show) + +type Config :: Type +data Config = Config + { maxRounds :: Natural + } + deriving stock (Eq, Ord, Show) + +-- | A repair run report, not a certificate. Every judgment it carries is +-- relative to the caller-supplied 'Kernel': 'ResultConverged' +-- means the kernel's own check accepted the state, so the constructors stay +-- public — fabricating a result asserts nothing that supplying a vacuous +-- kernel could not already assert. Truthfulness relative to a given kernel is +-- the post-condition of 'boundedRepair', never an invariant of this type. +type Result :: Type -> Type -> Type +data Result state obstruction + = ResultConverged state Natural + | ResultStuck state (NonEmpty obstruction) Natural + | ResultBudgetExhausted state (NonEmpty obstruction) Natural + deriving stock (Eq, Show) + +-- | A round-by-round account of a repair run, in chronological order. Like +-- 'Result' it is a description relative to the kernel that produced it; +-- consumers may construct traces directly (an empty trace is the natural +-- seed for accumulation) because the type never promises the run happened. +type Trace :: Type -> Type -> Type +newtype Trace obstruction correction = Trace + { rounds :: [Round obstruction correction] + } + deriving stock (Eq, Show) + +type Round :: Type -> Type -> Type +newtype Round obstruction correction = Round + { roundCorrections :: NonEmpty (Correction obstruction correction) + } + deriving stock (Eq, Show) + +type Correction :: Type -> Type -> Type +data Correction obstruction correction + = Applied obstruction correction + | Irreducible obstruction + deriving stock (Eq, Show) + +type StepOutput :: Type -> Type -> Type -> Type +data StepOutput state obstruction correction + = StepFinished !(Result state obstruction) !(Maybe (Round obstruction correction)) + | StepAdvanced !Natural !state !(Round obstruction correction) + +roundsUsed :: Result state obstruction -> Natural +roundsUsed result = + case result of + ResultConverged _ rounds -> rounds + ResultStuck _ _ rounds -> rounds + ResultBudgetExhausted _ _ rounds -> rounds + +isConverged :: Result state obstruction -> Bool +isConverged result = + case result of + ResultConverged _ _ -> True + _ -> False + +resultState :: Result state obstruction -> state +resultState result = + case result of + ResultConverged state _ -> state + ResultStuck state _ _ -> state + ResultBudgetExhausted state _ _ -> state + +boundedRepair :: + Kernel state obstruction correction -> + Config -> + state -> + Result state obstruction +boundedRepair kernel config initialState = + go 0 initialState + where + go currentRound state = + case stepOutput kernel config currentRound state of + StepFinished result _ -> + result + StepAdvanced nextRound nextState _ -> + go nextRound nextState + +boundedRepairTraced :: + Kernel state obstruction correction -> + Config -> + state -> + (Result state obstruction, Trace obstruction correction) +boundedRepairTraced kernel config initialState = + go 0 initialState [] + where + go currentRound state rounds = + case stepOutput kernel config currentRound state of + StepFinished result maybeRound -> + (result, Trace (reverse (maybe rounds (: rounds) maybeRound))) + StepAdvanced nextRound nextState roundValue -> + go nextRound nextState (roundValue : rounds) + +stepOutput :: + Kernel state obstruction correction -> + Config -> + Natural -> + state -> + StepOutput state obstruction correction +stepOutput kernel config currentRound state + | currentRound >= maxRounds config = + case check kernel state of + StepConverged convergedState -> + StepFinished (ResultConverged convergedState currentRound) Nothing + StepObstructed obstructedState obstructionValues -> + StepFinished (ResultBudgetExhausted obstructedState obstructionValues currentRound) Nothing + | otherwise = + case check kernel state of + StepConverged convergedState -> + StepFinished (ResultConverged convergedState currentRound) Nothing + StepObstructed obstructedState obstructionValues -> + obstructedStepOutput kernel currentRound obstructedState obstructionValues + +obstructedStepOutput :: + Kernel state obstruction correction -> + Natural -> + state -> + NonEmpty obstruction -> + StepOutput state obstruction correction +obstructedStepOutput kernel currentRound obstructedState obstructionValues = + case roundDeltas roundValue of + [] -> + StepFinished (ResultStuck obstructedState obstructionValues currentRound) (Just roundValue) + deltas -> + StepAdvanced + (currentRound + 1) + (foldl' (applyKernelCorrection kernel) obstructedState deltas) + roundValue + where + roundValue = + roundFor kernel obstructionValues + +roundFor :: + Kernel state obstruction correction -> + NonEmpty obstruction -> + Round obstruction correction +roundFor kernel obstructionValues = + Round correctionsValue + where + correctionsValue = + fmap (correctionFor kernel) obstructionValues + +corrections :: Round obstruction correction -> NonEmpty (Correction obstruction correction) +corrections = + roundCorrections + +obstructions :: Round obstruction correction -> NonEmpty obstruction +obstructions = + fmap correctionObstruction . roundCorrections + +applied :: Round obstruction correction -> Natural +applied = + fromIntegral . length . roundDeltas + +appliedCorrections :: Round obstruction correction -> [correction] +appliedCorrections = + roundDeltas + +irreducible :: Round obstruction correction -> [obstruction] +irreducible = + roundIrreducibleFromCorrections . roundCorrections + +correctionObstruction :: Correction obstruction correction -> obstruction +correctionObstruction correction = + case correction of + Applied obstruction _ -> obstruction + Irreducible obstruction -> obstruction + +correctionFor :: + Kernel state obstruction correction -> + obstruction -> + Correction obstruction correction +correctionFor kernel obstruction = + case residuate kernel obstruction of + Nothing -> Irreducible obstruction + Just correction -> Applied obstruction correction + +roundDeltas :: Round obstruction correction -> [correction] +roundDeltas = + roundDeltasFromCorrections . roundCorrections + +roundDeltasFromCorrections :: NonEmpty (Correction obstruction correction) -> [correction] +roundDeltasFromCorrections = + concatMap (maybeToList . correctionDelta) . NonEmpty.toList + +correctionDelta :: Correction obstruction correction -> Maybe correction +correctionDelta correction = + case correction of + Applied _ delta -> Just delta + Irreducible _ -> Nothing + +roundIrreducibleFromCorrections :: NonEmpty (Correction obstruction correction) -> [obstruction] +roundIrreducibleFromCorrections = + concatMap (maybeToList . correctionIrreducible) . NonEmpty.toList + +correctionIrreducible :: Correction obstruction correction -> Maybe obstruction +correctionIrreducible correction = + case correction of + Applied _ _ -> Nothing + Irreducible obstruction -> Just obstruction + +sequenceRepair :: + Kernel state obstruction1 correction1 -> + Kernel state obstruction2 correction2 -> + Kernel state (Either obstruction1 obstruction2) (Either correction1 correction2) +sequenceRepair kernel1 kernel2 = + Kernel + { check = \state -> + case check kernel1 state of + StepObstructed obstructedState obstructionValues -> + StepObstructed obstructedState (fmap Left obstructionValues) + StepConverged convergedState -> + case check kernel2 convergedState of + StepConverged finalState -> + StepConverged finalState + StepObstructed obstructedState obstructionValues -> + StepObstructed obstructedState (fmap Right obstructionValues), + residuate = + either + (fmap Left . residuate kernel1) + (fmap Right . residuate kernel2), + applyKernelCorrection = \state eitherDelta -> + case eitherDelta of + Left delta1 -> applyKernelCorrection kernel1 state delta1 + Right delta2 -> applyKernelCorrection kernel2 state delta2 + } + +productRepair :: + Kernel state obstruction1 correction1 -> + Kernel state obstruction2 correction2 -> + Kernel state (Either obstruction1 obstruction2) (Either correction1 correction2) +productRepair kernel1 kernel2 = + Kernel + { check = \state -> + let leftStep = check kernel1 state + leftState = stepState leftStep + rightStep = check kernel2 leftState + rightState = stepState rightStep + in case (leftStep, rightStep) of + (StepConverged _, StepConverged _) -> + StepConverged rightState + (StepObstructed _ obs1, StepConverged _) -> + StepObstructed rightState (fmap Left obs1) + (StepConverged _, StepObstructed _ obs2) -> + StepObstructed rightState (fmap Right obs2) + (StepObstructed _ obs1, StepObstructed _ obs2) -> + StepObstructed rightState (fmap Left obs1 <> fmap Right obs2), + residuate = + either + (fmap Left . residuate kernel1) + (fmap Right . residuate kernel2), + applyKernelCorrection = \state eitherDelta -> + case eitherDelta of + Left delta1 -> applyKernelCorrection kernel1 state delta1 + Right delta2 -> applyKernelCorrection kernel2 state delta2 + } + +focusRepair :: + (state -> focus) -> + (state -> focus -> state) -> + Kernel focus obstruction correction -> + Kernel state obstruction correction +focusRepair extract embed innerKernel = + Kernel + { check = \state -> + case check innerKernel (extract state) of + StepConverged innerConvergedValue -> StepConverged (embed state innerConvergedValue) + StepObstructed innerObstructedValue obstructionValues -> StepObstructed (embed state innerObstructedValue) obstructionValues, + residuate = residuate innerKernel, + applyKernelCorrection = \state delta -> + embed state (applyKernelCorrection innerKernel (extract state) delta) + } + +identityRepair :: Kernel state obstruction correction +identityRepair = + Kernel + { check = StepConverged, + residuate = const Nothing, + applyKernelCorrection = const + } + +mapRepair :: + (obstruction1 -> obstruction2) -> + (obstruction2 -> obstruction1) -> + (correction1 -> correction2) -> + (correction2 -> correction1) -> + Kernel state obstruction1 correction1 -> + Kernel state obstruction2 correction2 +mapRepair forwardObs backwardObs forwardDelta backwardDelta innerKernel = + Kernel + { check = \state -> + case check innerKernel state of + StepConverged convergedState -> + StepConverged convergedState + StepObstructed obstructedState obstructionValues -> + StepObstructed obstructedState (fmap forwardObs obstructionValues), + residuate = + fmap forwardDelta . residuate innerKernel . backwardObs, + applyKernelCorrection = \state delta -> + applyKernelCorrection innerKernel state (backwardDelta delta) + } + +stepState :: Step state obstruction -> state +stepState step = + case step of + StepConverged state -> state + StepObstructed state _ -> state diff --git a/test-support/DeltaLaws.hs b/test-support/DeltaLaws.hs new file mode 100644 --- /dev/null +++ b/test-support/DeltaLaws.hs @@ -0,0 +1,454 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module DeltaLaws + ( deltaNormalizeLaws, + deltaSupportLaws, + frontierLaws, + signedLaws, + functorLaws, + monotoneLaws, + ) +where + +import Data.Foldable qualified as Foldable +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Moonlight.Core (IsLawName (..), constructorLawName) +import Moonlight.Core + ( PartialOrder (..), + ) +import LawManifest + ( lawManifestCase, + lawProperty, + ) +import Moonlight.Delta.Frontier +import Moonlight.Delta.Monotone +import Moonlight.Delta.Normalize +import Moonlight.Delta.Signed +import Moonlight.Delta.Support +import Test.QuickCheck + ( Gen, + Property, + chooseInt, + conjoin, + forAll, + (===), + ) +import Test.Tasty (TestTree, testGroup) + +data DeltaNormalizeLaw + = DeltaNormalizeIdempotent + | DeltaNormalizeNullStable + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName DeltaNormalizeLaw where + lawNameText = + constructorLawName . show + +data DeltaSupportLaw + = DeltaSupportNormalizeStable + | DeltaSupportNullDeltaEmpty + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName DeltaSupportLaw where + lawNameText = + constructorLawName . show + +data FrontierLaw + = FrontierLowerAntichain + | FrontierLowerCoversInput + | FrontierLowerCanonical + | FrontierLowerInputOrderInvariant + | FrontierLowerObservationOrderInvariant + | FrontierUpperAntichain + | FrontierUpperCoversInput + | FrontierUpperCanonical + | FrontierUpperInputOrderInvariant + | FrontierUpperObservationOrderInvariant + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName FrontierLaw where + lawNameText = + constructorLawName . show + +data SignedLaw + = SignedCanonicalByConstruction + | SignedIdentityCombination + | SignedCombinationAssociative + | SignedCombinationApplicationSequential + | SignedInverseCancellation + | SignedApplySuccessUpdatesStateAndDeletesZero + | SignedUnderflowRejected + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName SignedLaw where + lawNameText = + constructorLawName . show + +data FunctorLaw + = FunctorIdentity + | FunctorComposition + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName FunctorLaw where + lawNameText = + constructorLawName . show + +data MonotoneLaw + = MonotoneCompositionSequentialApplication + | MonotoneResetLeftAbsorption + | MonotoneResetApplication + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName MonotoneLaw where + lawNameText = + constructorLawName . show + +deltaNormalizeLaws :: + forall delta. + (DeltaNormalize delta, Eq delta, Show delta) => + String -> + Gen delta -> + TestTree +deltaNormalizeLaws label deltaGen = + testGroup + label + [ lawManifestCase label ([minBound .. maxBound] :: [DeltaNormalizeLaw]), + lawProperty DeltaNormalizeIdempotent $ forAll deltaGen $ \deltaValue -> + normalizeDelta (normalizeDelta deltaValue) === normalizeDelta deltaValue, + lawProperty DeltaNormalizeNullStable $ forAll deltaGen $ \deltaValue -> + deltaNull (normalizeDelta deltaValue) === deltaNull deltaValue + ] + +deltaSupportLaws :: + forall delta. + ( DeltaNormalize delta, + DeltaSupport delta, + Eq (DeltaSupportSet delta), + Show (DeltaSupportSet delta), + Show delta + ) => + String -> + Gen delta -> + Gen delta -> + TestTree +deltaSupportLaws label deltaGen nullDeltaGen = + testGroup + label + [ lawManifestCase label ([minBound .. maxBound] :: [DeltaSupportLaw]), + lawProperty DeltaSupportNormalizeStable $ forAll deltaGen $ \deltaValue -> + deltaSupport (normalizeDelta deltaValue) === deltaSupport deltaValue, + lawProperty DeltaSupportNullDeltaEmpty $ forAll nullDeltaGen $ \deltaValue -> + let normalized = normalizeDelta deltaValue + in (deltaNull normalized, deltaSupport normalized) + === (True, emptySupport @delta) + ] + +frontierLaws :: + forall time. + (Ord time, PartialOrder time, Eq time, Show time) => + String -> + Gen [time] -> + TestTree +frontierLaws label timesGen = + testGroup + label + [ lawManifestCase label ([minBound .. maxBound] :: [FrontierLaw]), + lawProperty FrontierLowerAntichain $ forAll timesGen $ \times -> + frontierIsAntichain (frontierPoints (mkFrontier times)) === True, + lawProperty FrontierLowerCoversInput $ forAll timesGen $ \times -> + lowerFrontierCovers times (mkFrontier times) === True, + lawProperty FrontierLowerCanonical $ forAll timesGen $ \times -> + mkFrontier (frontierPoints (mkFrontier times)) === mkFrontier times, + lawProperty FrontierLowerInputOrderInvariant $ forAll timesGen $ \times -> + mkFrontier (reverse times) === mkFrontier times, + lawProperty FrontierLowerObservationOrderInvariant $ forAll timesGen $ \times -> + let forward = mkFrontier times + backward = mkFrontier (reverse times) + in (frontierPoints forward, show forward) === (frontierPoints backward, show backward), + lawProperty FrontierUpperAntichain $ forAll timesGen $ \times -> + frontierIsAntichain (upperFrontierPoints (mkUpperFrontier times)) === True, + lawProperty FrontierUpperCoversInput $ forAll timesGen $ \times -> + upperFrontierCovers times (mkUpperFrontier times) === True, + lawProperty FrontierUpperCanonical $ forAll timesGen $ \times -> + mkUpperFrontier (upperFrontierPoints (mkUpperFrontier times)) === mkUpperFrontier times, + lawProperty FrontierUpperInputOrderInvariant $ forAll timesGen $ \times -> + mkUpperFrontier (reverse times) === mkUpperFrontier times, + lawProperty FrontierUpperObservationOrderInvariant $ forAll timesGen $ \times -> + let forward = mkUpperFrontier times + backward = mkUpperFrontier (reverse times) + in (upperFrontierPoints forward, show forward) === (upperFrontierPoints backward, show backward) + ] + +signedLaws :: + forall key. + (Ord key, Show key) => + String -> + Gen [(key, Int)] -> + Gen key -> + TestTree +signedLaws label entriesGen keyGen = + testGroup + label + [ lawManifestCase label ([minBound .. maxBound] :: [SignedLaw]), + deltaNormalizeLaws "normalize" (signedFromList <$> entriesGen), + lawProperty SignedCanonicalByConstruction $ forAll signedCanonicalGen signedCanonicalByConstruction, + lawProperty SignedIdentityCombination $ forAll entriesGen signedIdentity, + lawProperty SignedCombinationAssociative $ forAll signedTripleGen signedAssociativity, + lawProperty SignedCombinationApplicationSequential $ forAll signedSequentialApplicationGen signedCombinationApplicationSequential, + lawProperty SignedInverseCancellation $ forAll entriesGen signedInverse, + lawProperty SignedApplySuccessUpdatesStateAndDeletesZero $ forAll signedApplySuccessGen signedApplySuccess, + lawProperty SignedUnderflowRejected $ forAll signedUnderflowGen signedUnderflow + ] + where + signedTripleGen :: Gen ([(key, Int)], [(key, Int)], [(key, Int)]) + signedTripleGen = + (,,) <$> entriesGen <*> entriesGen <*> entriesGen + + signedCanonicalGen :: Gen (key, [(key, Int)], [(key, Int)], [(key, Int)]) + signedCanonicalGen = + (,,,) <$> keyGen <*> entriesGen <*> entriesGen <*> entriesGen + + signedUnderflowGen :: Gen (key, Int) + signedUnderflowGen = + (,) <$> keyGen <*> chooseInt (1, 64) + + signedCanonicalByConstruction :: (key, [(key, Int)], [(key, Int)], [(key, Int)]) -> Property + signedCanonicalByConstruction (canonicalKey, olderEntries, middleEntries, newerEntries) = + let older = signedFromList olderEntries + middle = signedFromList middleEntries + newer = signedFromList newerEntries + combined = combineSigned newer (combineSigned middle older) + negated = negateSigned combined + fromChangeMap = + signedFromChangeMap + ( Map.fromList + (fmap (\(key, amount) -> (key, MultiplicityChange (fromIntegral amount))) olderEntries) + ) + mapped = mapSignedKeys (const canonicalKey) combined + traversed = + traverseSignedKeysWith + (\_ -> Right canonicalKey :: Either () key) + combined + in conjoin + [ signedCanonicalRows (emptySigned :: Signed key), + signedCanonicalRows (singletonSigned canonicalKey 0), + signedCanonicalRows (singletonSigned canonicalKey 1), + signedCanonicalRows older, + signedCanonicalRows fromChangeMap, + signedCanonicalRows combined, + signedCanonicalRows negated, + signedCanonicalRows mapped, + fmap signedToAscList traversed === Right (signedToAscList mapped) + ] + + signedCanonicalRows :: Signed key -> Property + signedCanonicalRows signedValue = + let rows = signedToAscList signedValue + canonicalRows = + Map.toAscList + ( Map.filter + (/= zeroMultiplicityChange) + (Map.fromListWith addMultiplicityChange rows) + ) + in rows === canonicalRows + + signedSequentialApplicationGen :: Gen ([(key, Int)], [(key, Int)], [(key, Int)]) + signedSequentialApplicationGen = + (,,) <$> entriesGen <*> entriesGen <*> entriesGen + + signedApplySuccessGen :: Gen (key, Int, Int, Int, Int) + signedApplySuccessGen = + (,,,,) + <$> keyGen + <*> chooseInt (1, 64) + <*> chooseInt (1, 64) + <*> chooseInt (1, 64) + <*> chooseInt (1, 64) + + signedIdentity :: [(key, Int)] -> Property + signedIdentity entries = + let deltaValue = signedFromList entries + in ( combineSigned emptySigned deltaValue, + combineSigned deltaValue emptySigned + ) + === (deltaValue, deltaValue) + + signedAssociativity :: ([(key, Int)], [(key, Int)], [(key, Int)]) -> Property + signedAssociativity (olderEntries, middleEntries, newerEntries) = + let older = signedFromList olderEntries + middle = signedFromList middleEntries + newer = signedFromList newerEntries + in combineSigned newer (combineSigned middle older) + === combineSigned (combineSigned newer middle) older + + signedCombinationApplicationSequential :: ([(key, Int)], [(key, Int)], [(key, Int)]) -> Property + signedCombinationApplicationSequential (olderEntries, newerEntries, stateEntries) = + let older = signedFromList olderEntries + newer = signedFromList newerEntries + state = signedSequentialState olderEntries newerEntries stateEntries + in applySignedToMap (combineSigned newer older) state + === (applySignedToMap older state >>= applySignedToMap newer) + + signedInverse :: [(key, Int)] -> Property + signedInverse entries = + let deltaValue = signedFromList entries + in combineSigned (negateSigned deltaValue) deltaValue + === emptySigned + + signedApplySuccess :: (key, Int, Int, Int, Int) -> Property + signedApplySuccess (key, insertAmount, incrementStart, incrementAmount, deleteStart) = + let observed = + ( fmap (fmap multiplicityValue) $ + applySignedToMap + (signedFromList [(key, insertAmount)]) + Map.empty, + fmap (fmap multiplicityValue) $ + applySignedToMap + (signedFromList [(key, incrementAmount)]) + (Map.singleton key (Multiplicity (fromIntegral incrementStart))), + fmap (fmap multiplicityValue) $ + applySignedToMap + (signedFromList [(key, negate deleteStart)]) + (Map.singleton key (Multiplicity (fromIntegral deleteStart))) + ) + expected = + ( Right (Map.singleton key (fromIntegral insertAmount)), + Right (Map.singleton key (fromIntegral (incrementStart + incrementAmount))), + Right Map.empty + ) + in observed === expected + + signedSequentialState :: [(key, Int)] -> [(key, Int)] -> [(key, Int)] -> Map key Multiplicity + signedSequentialState olderEntries newerEntries stateEntries = + let baseState = signedStateFromEntries stateEntries + olderTotals = signedEntryTotals olderEntries + newerTotals = signedEntryTotals newerEntries + deltaKeys = Map.keys (Map.union olderTotals newerTotals) + requirements = + Map.fromList + [ (key, Multiplicity (fromIntegral required)) + | key <- deltaKeys, + let olderChange = Map.findWithDefault 0 key olderTotals, + let newerChange = Map.findWithDefault 0 key newerTotals, + let required = max 0 (max (negate olderChange) (negate (olderChange + newerChange))), + required > 0 + ] + in Map.unionWith max baseState requirements + + signedStateFromEntries :: [(key, Int)] -> Map key Multiplicity + signedStateFromEntries entries = + Map.fromList + [ (key, Multiplicity (fromIntegral amount)) + | (key, rawAmount) <- Map.toList (signedEntryTotals entries), + let amount = abs rawAmount, + amount > 0 + ] + + signedEntryTotals :: [(key, Int)] -> Map key Int + signedEntryTotals = + Map.fromListWith (+) + + signedUnderflow :: (key, Int) -> Property + signedUnderflow (key, amount) = + applySignedToMap + (singletonSigned key (negate amount)) + (Map.singleton key (Multiplicity (fromIntegral (amount - 1)))) + === Left + SignedMultiplicityUnderflow + { saeKey = key, + saeOldMultiplicity = Multiplicity (fromIntegral (amount - 1)), + saeDeltaMultiplicity = MultiplicityChange (fromIntegral (negate amount)) + } + +functorLaws :: + forall f. + (Functor f, Eq (f Int), Show (f Int)) => + String -> + Gen (f Int) -> + TestTree +functorLaws label valueGen = + testGroup + label + [ lawManifestCase label ([minBound .. maxBound] :: [FunctorLaw]), + lawProperty FunctorIdentity $ forAll valueGen $ \value -> + fmap identityInt value === value, + lawProperty FunctorComposition $ forAll valueGen $ \value -> + fmap (incrementInt . doubleInt) value === fmapSequential value + ] + +identityInt :: Int -> Int +identityInt value = + value + +doubleInt :: Int -> Int +doubleInt value = + value * 2 + +incrementInt :: Int -> Int +incrementInt value = + value + 1 + +fmapSequential :: Functor f => f Int -> f Int +fmapSequential value = + let doubled = fmap doubleInt value + in fmap incrementInt doubled + +monotoneLaws :: + forall value. + (Eq value, Show value) => + String -> + (value -> value -> value) -> + Gen (Monotone value, Monotone value, value) -> + TestTree +monotoneLaws label joinValue sectionGen = + testGroup + label + [ lawManifestCase label ([minBound .. maxBound] :: [MonotoneLaw]), + lawProperty MonotoneCompositionSequentialApplication $ forAll sectionGen $ \(newer, older, stateValue) -> + applyDelta joinValue (composeDelta joinValue newer older) stateValue + === applyDelta joinValue newer (applyDelta joinValue older stateValue), + lawProperty MonotoneResetLeftAbsorption $ forAll sectionGen $ \(newer, older, _stateValue) -> + let target = + monotoneDeltaValue newer + in composeDelta joinValue (ResetDelta target) older + === ResetDelta target, + lawProperty MonotoneResetApplication $ forAll sectionGen $ \(newer, _older, stateValue) -> + let target = + monotoneDeltaValue newer + in applyDelta joinValue (ResetDelta target) stateValue + === target + ] + +monotoneDeltaValue :: Monotone value -> value +monotoneDeltaValue delta = + case delta of + JoinDelta value -> + value + ResetDelta value -> + value + +frontierIsAntichain :: (PartialOrder time, Eq time) => [time] -> Bool +frontierIsAntichain points = + Foldable.all + (\left -> + Foldable.all + (\right -> left == right || (not (left `leq` right) && not (right `leq` left))) + points) + points + +lowerFrontierCovers :: PartialOrder time => [time] -> Frontier time -> Bool +lowerFrontierCovers times frontier = + Foldable.all + (\time -> Foldable.any (`leq` time) (frontierPoints frontier)) + times + +upperFrontierCovers :: PartialOrder time => [time] -> UpperFrontier time -> Bool +upperFrontierCovers times frontier = + Foldable.all + (\time -> Foldable.any (time `leq`) (upperFrontierPoints frontier)) + times diff --git a/test-support/LawManifest.hs b/test-support/LawManifest.hs new file mode 100644 --- /dev/null +++ b/test-support/LawManifest.hs @@ -0,0 +1,36 @@ +module LawManifest + ( lawManifestCase, + lawProperty, + ) +where + +import Moonlight.Core (IsLawName (..)) +import Moonlight.Core + ( canonicalTheoremManifestNames, + parseTheoremManifestNames, + renderTheoremManifestJson, + ) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) +import Test.Tasty.QuickCheck (Testable, testProperty) + +lawProperty :: (IsLawName law, Testable property) => law -> property -> TestTree +lawProperty lawName = + testProperty (lawNameText lawName) + +lawManifestCase :: IsLawName law => String -> [law] -> TestTree +lawManifestCase owner lawNames = + testCase (owner <> " law names satisfy proof manifest boundary") $ + case parseTheoremManifestNames renderedManifest of + Left manifestError -> + assertFailure (show manifestError) + Right parsedLawNames -> do + length manifestNames @?= length canonicalLawNames + parsedLawNames @?= canonicalLawNames + where + manifestNames = + lawNameText <$> lawNames + canonicalLawNames = + canonicalTheoremManifestNames manifestNames + renderedManifest = + renderTheoremManifestJson manifestNames diff --git a/test-support/PatchReference.hs b/test-support/PatchReference.hs new file mode 100644 --- /dev/null +++ b/test-support/PatchReference.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module PatchReference + ( compose, + apply, + replay, + ) +where + +import Data.Foldable qualified as Foldable +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Map.Merge.Strict qualified as MapMerge +import Moonlight.Delta.Patch + ( ApplyError (..), + CellPatch, + ComposeError (..), + PatchKey, + PatchValue, + Patch, + ReplayError (..), + ) +import Moonlight.Delta.Patch qualified as Patch +import Numeric.Natural + ( Natural, + ) +import Prelude + ( Either (Left, Right), + Eq, + Foldable, + Maybe (Just, Nothing), + Ord, + fmap, + (+), + (.), + (==), + ) + +compose :: + forall key value. + (PatchKey key, PatchValue value) => + Patch key value -> + Patch key value -> + Either (ComposeError key value) (Patch key value) +compose newer older = + fmap (Patch.fromAscList . Map.toAscList) + ( MapMerge.mergeA + MapMerge.preserveMissing + MapMerge.preserveMissing + (MapMerge.zipWithAMatched composeMatched) + (Map.fromDistinctAscList (Patch.toAscList newer)) + (Map.fromDistinctAscList (Patch.toAscList older)) + ) + where + composeMatched :: + key -> + CellPatch value -> + CellPatch value -> + Either (ComposeError key value) (CellPatch value) + composeMatched key newerCell olderCell = + if Patch.cellAfter olderCell == Patch.cellBefore newerCell + then + Right + ( Patch.cellFromEndpoints + (Patch.cellBefore olderCell) + (Patch.cellAfter newerCell) + ) + else + Left + ComposeBoundaryMismatch + { boundaryKey = key, + olderAfter = Patch.cellAfter olderCell, + newerBefore = Patch.cellBefore newerCell + } +{-# INLINABLE compose #-} + +apply :: + forall key value. + (Ord key, Eq value) => + Patch key value -> + Map key value -> + Either (ApplyError key value) (Map key value) +apply patch state = + MapMerge.mergeA + (MapMerge.traverseMaybeMissing applyToMissing) + MapMerge.preserveMissing + (MapMerge.zipWithMaybeAMatched applyToPresent) + (Map.fromDistinctAscList (Patch.toAscList patch)) + state + where + applyToMissing :: + key -> + CellPatch value -> + Either (ApplyError key value) (Maybe value) + applyToMissing key cell = + applyCell key cell Nothing + + applyToPresent :: + key -> + CellPatch value -> + value -> + Either (ApplyError key value) (Maybe value) + applyToPresent key cell actualValue = + applyCell key cell (Just actualValue) +{-# INLINABLE apply #-} + +replay :: + forall patches key value. + (Foldable patches, PatchKey key, PatchValue value) => + patches (Patch key value) -> + Map key value -> + Either (ReplayError key value) (Map key value) +replay patches initialState = + case Foldable.foldlM applyStep (0, initialState) patches of + Left err -> + Left err + Right (_nextIndex, state) -> + Right state + where + applyStep :: + (Natural, Map key value) -> + Patch key value -> + Either (ReplayError key value) (Natural, Map key value) + applyStep (index, state) patch = + case apply patch state of + Left err -> + Left + ReplayApplyError + { replayIndex = index, + replayApply = err + } + Right nextState -> + Right (index + 1, nextState) +{-# INLINABLE replay #-} + +applyCell :: + Eq value => + key -> + CellPatch value -> + Maybe value -> + Either (ApplyError key value) (Maybe value) +applyCell key cell actualBefore = + if Patch.cellBefore cell == actualBefore + then Right (Patch.cellAfter cell) + else + Left + ApplyBeforeMismatch + { mismatchKey = key, + expectedBefore = Patch.cellBefore cell, + actualBefore = actualBefore + } +{-# INLINE applyCell #-} + diff --git a/test/aggregate/Main.hs b/test/aggregate/Main.hs new file mode 100644 --- /dev/null +++ b/test/aggregate/Main.hs @@ -0,0 +1,20 @@ +module Main (main) where + +import qualified CoreTests +import qualified CrossCarrierLaws +import qualified EpochTests +import qualified PatchTests +import qualified RepairTests +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain $ + testGroup + "moonlight-delta" + [ CoreTests.tests, + PatchTests.tests, + EpochTests.tests, + RepairTests.tests, + CrossCarrierLaws.tests + ] diff --git a/test/core/CoreTests.hs b/test/core/CoreTests.hs new file mode 100644 --- /dev/null +++ b/test/core/CoreTests.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE DerivingStrategies #-} + +module CoreTests + ( tests, + ) +where + +import Data.IntSet qualified as IntSet +import Moonlight.Core + ( PartialOrder (..), + ) +import Moonlight.Delta.Frontier +import DeltaLaws +import Moonlight.Delta.Monotone +import Moonlight.Delta.Operator +import Moonlight.Delta.Scope +import Moonlight.Delta.Time +import Test.QuickCheck + ( Gen, + chooseInt, + elements, + listOf, + oneof, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) + +newtype TotalTime = TotalTime + { unTotalTime :: Int + } + deriving stock (Eq, Ord, Show) + +instance PartialOrder TotalTime where + leq left right = + unTotalTime left <= unTotalTime right + +data ProductTime = ProductTime + { productTimeLeft :: !Int, + productTimeRight :: !Int + } + deriving stock (Eq, Ord, Show) + +instance PartialOrder ProductTime where + leq left right = + productTimeLeft left <= productTimeLeft right + && productTimeRight left <= productTimeRight right + +tupleProductTime :: (Int, Int) -> ProductTime +tupleProductTime (left, right) = + ProductTime left right + +tests :: TestTree +tests = + testGroup + "core" + [ scopeTests, + signedTests, + frontierTests, + operatorTests, + monotoneTests + ] + +scopeTests :: TestTree +scopeTests = + testGroup + "scope" + [ testCase "normalization preserves payload orthogonally" $ + let emptyPayloadDelta = + scopedDelta (dirtyScope IntSet.empty) (Just (IntSet.singleton 1)) + in do + scopedDeltaSupport emptyPayloadDelta @?= cleanScope + scopedDeltaPayload emptyPayloadDelta @?= Just (IntSet.singleton 1) + scopedDeltaNull emptyPayloadDelta @?= False, + testCase "full scope can carry payload" $ + let deltaValue = + scopedDelta fullScope (Just (IntSet.singleton 7)) :: + Scoped IntSet.IntSet IntSet.IntSet + in do + normalizeScoped deltaValue @?= deltaValue + scopedDeltaSupport deltaValue @?= fullScope + scopedDeltaPayload deltaValue @?= Just (IntSet.singleton 7), + testCase "payload merge uses Maybe semigroup structure" $ + let leftDelta = + payloadDelta (IntSet.singleton 1) :: + Scoped IntSet.IntSet IntSet.IntSet + rightDelta = + scopedDelta (dirtyScope (IntSet.singleton 2)) (Just (IntSet.singleton 3)) + emptyPayloadDelta = + scopedDelta (dirtyScope (IntSet.singleton 4)) Nothing :: + Scoped IntSet.IntSet IntSet.IntSet + in do + scopedDeltaPayload (leftDelta <> rightDelta) + @?= Just (IntSet.fromList [1, 3]) + scopedDeltaPayload (leftDelta <> emptyPayloadDelta) + @?= Just (IntSet.singleton 1), + testCase "restriction intersects dirty scopes and bounds full scopes" $ + let leftRestriction = IntSet.fromList [1, 2, 3] + rightRestriction = IntSet.fromList [2, 3, 4] + restricted = + restrictScope leftRestriction + (restrictScope rightRestriction fullScope) + in do + restricted @?= dirtyScope (IntSet.fromList [2, 3]) + scopeKeys restricted @?= Just (IntSet.fromList [2, 3]) + restrictScope IntSet.empty fullScope @?= cleanScope, + testCase "scope equality is canonical after normalization" $ + let emptyDirtyScope = + dirtyScope IntSet.empty + in do + emptyDirtyScope @?= (cleanScope :: Scope IntSet.IntSet) + compare emptyDirtyScope (cleanScope :: Scope IntSet.IntSet) @?= EQ, + testCase "scope constructors and mapping normalize empty dirty scopes" $ + let dirty = + dirtyScope (IntSet.singleton 1) + mappedEmpty = + mapScope (const IntSet.empty) dirty + in do + dirtyScope IntSet.empty @?= (cleanScope :: Scope IntSet.IntSet) + mappedEmpty @?= (cleanScope :: Scope IntSet.IntSet) + ] + +signedTests :: TestTree +signedTests = + signedLaws "signed" signedEntriesGen signedKeyGen + +frontierTests :: TestTree +frontierTests = + testGroup + "frontier" + [ frontierLaws "total time" totalTimesGen, + frontierLaws "product time" productTimesGen, + testCase "product frontier removes dominated points" $ + frontierPoints + ( mkFrontier + [ ProductTime 1 2, + ProductTime 1 1, + ProductTime 2 1 + ] + ) + @?= [ProductTime 1 1], + testCase "product frontier stores a searchable skyline staircase" $ + let frontier = + mkProductFrontier2 [(0 :: Int, 3 :: Int), (1, 2), (2, 1), (3, 0), (3, 4)] + in ( productFrontier2Points frontier, + productFrontier2Contains (2, 2) frontier, + productFrontier2Contains (0, 2) frontier + ) + @?= ([(0, 3), (1, 2), (2, 1), (3, 0)], True, False), + testCase "product frontier containment agrees with generic product order" $ + let diagonal = [(0 :: Int, 4 :: Int), (1, 3), (2, 2), (3, 1), (4, 0)] + probes = [(0, 0), (1, 4), (2, 3), (4, 4), (5, 0)] + genericFrontier = mkFrontier (fmap tupleProductTime diagonal) + productFrontier = mkProductFrontier2 diagonal + in fmap + (\probe -> + ( frontierContains (tupleProductTime probe) genericFrontier, + productFrontier2Contains probe productFrontier + ) + ) + probes + @?= fmap (\contains -> (contains, contains)) [False, True, True, True, True] + ] + +operatorTests :: TestTree +operatorTests = + testGroup + "operator" + [ functorLaws "Timed" timedIntGen, + functorLaws "OpResult" opResultIntGen, + testCase "retime preserves payload" $ + retime + (TotalTime 9) + (Timed (TotalTime 1) ("payload" :: String)) + @?= Timed (TotalTime 9) "payload", + testCase "retimeOpResult retimes every emitted value" $ + retimeOpResult + (TotalTime 7) + ( OpResult + { orState = "state" :: String, + orEmit = + [ Timed (TotalTime 1) ("a" :: String), + Timed (TotalTime 2) "b" + ] + } + ) + @?= + OpResult + { orState = "state", + orEmit = + [ Timed (TotalTime 7) "a", + Timed (TotalTime 7) "b" + ] + } + ] + +monotoneTests :: TestTree +monotoneTests = + testGroup + "monotone" + [ monotoneLaws "monotone max" max monotoneSectionGen, + monotoneLaws "monotone addition" (+) monotoneSectionGen + ] + +signedKeyGen :: Gen Int +signedKeyGen = + chooseInt (0, 16) + +signedEntriesGen :: Gen [(Int, Int)] +signedEntriesGen = + listOf ((,) <$> signedKeyGen <*> chooseInt (-16, 16)) + +totalTimeGen :: Gen TotalTime +totalTimeGen = + TotalTime <$> chooseInt (0, 64) + +totalTimesGen :: Gen [TotalTime] +totalTimesGen = + listOf totalTimeGen + +productTimeGen :: Gen ProductTime +productTimeGen = + ProductTime + <$> chooseInt (0, 16) + <*> chooseInt (0, 16) + +productTimesGen :: Gen [ProductTime] +productTimesGen = + listOf productTimeGen + +timedIntGen :: Gen (Timed TotalTime Int) +timedIntGen = + Timed <$> totalTimeGen <*> chooseInt (-16, 16) + +opResultIntGen :: Gen (OpResult TotalTime String Int) +opResultIntGen = + OpResult + <$> elements ["left", "right"] + <*> listOf timedIntGen + +monotoneDeltaGen :: Gen (Monotone Int) +monotoneDeltaGen = + oneof + [ JoinDelta <$> chooseInt (-16, 16), + ResetDelta <$> chooseInt (-16, 16) + ] + +monotoneSectionGen :: Gen (Monotone Int, Monotone Int, Int) +monotoneSectionGen = + (,,) + <$> monotoneDeltaGen + <*> monotoneDeltaGen + <*> chooseInt (-16, 16) diff --git a/test/core/Main.hs b/test/core/Main.hs new file mode 100644 --- /dev/null +++ b/test/core/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified CoreTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain CoreTests.tests diff --git a/test/epoch/ComposeSpec.hs b/test/epoch/ComposeSpec.hs new file mode 100644 --- /dev/null +++ b/test/epoch/ComposeSpec.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module ComposeSpec + ( composeTests, + ) +where + +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet qualified as IntSet +import EpochSupport.Generators +import EpochSupport.Reference +import EpochSupport.Types +import LawManifest (lawManifestCase, lawProperty) +import Moonlight.Core (IsLawName (..), SetKey, constructorLawName) +import Moonlight.Delta.Epoch +import Test.QuickCheck (Property, counterexample, forAll, (===), (.&&.)) +import Test.Tasty (TestTree, testGroup) + +data EpochComposeLaw + = EpochComposeBoundaryMismatchRejected + | EpochComposeIdentityLeft + | EpochComposeIdentityRight + | EpochComposeAssociative + | EpochComposeAgreesWithSequentialReference + | EpochComposeDirtyTargetSequential + | EpochComposeRetireRecreateDirty + | EpochComposeRenameIntoRetirement + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName EpochComposeLaw where + lawNameText = constructorLawName . show + +composeTests :: TestTree +composeTests = + testGroup + "compose" + [ lawManifestCase "epoch compose" ([minBound .. maxBound] :: [EpochComposeLaw]), + lawProperty EpochComposeBoundaryMismatchRejected boundaryMismatchRejected, + lawProperty EpochComposeIdentityLeft $ + epochDeltaIntCaseProperty composeIdentityLeft + .&&. epochDeltaGenericCaseProperty composeIdentityLeft, + lawProperty EpochComposeIdentityRight $ + epochDeltaIntCaseProperty composeIdentityRight + .&&. epochDeltaGenericCaseProperty composeIdentityRight, + lawProperty EpochComposeAssociative $ + forAll stableEpochChainIntGen composeAssociative + .&&. forAll stableEpochChainGenericGen composeAssociative, + lawProperty EpochComposeAgreesWithSequentialReference $ + forAll epochPairIntGen composeAgreesWithReference, + lawProperty EpochComposeDirtyTargetSequential $ + forAll epochPairIntGen composeDirtyTargetSequential, + lawProperty EpochComposeRetireRecreateDirty retireRecreateDirty, + lawProperty EpochComposeRenameIntoRetirement renameIntoRetirement + ] + +boundaryMismatchRejected :: Property +boundaryMismatchRejected = + ( composeDelta newerVersion older, + composeDelta newerUniverse older + ) + === ( Left (ComposeVersionMismatch (versionFromKey 1) (versionFromKey 2)), + Left ComposeUniverseMismatch + ) + where + older = identityDelta (Endpoint (versionFromKey 1) (IntSet.singleton 0)) :: EpochDelta (IntMap.IntMap Int) IntSet.IntSet + newerVersion = identityDelta (Endpoint (versionFromKey 2) (IntSet.singleton 0)) + newerUniverse = identityDelta (Endpoint (versionFromKey 1) (IntSet.singleton 1)) + +composeIdentityLeft :: + (EpochKeyed keyMap observed, Eq observed, Eq keyMap, Show observed, Show keyMap, Show (SetKey observed)) => + EpochDeltaCase keyMap observed -> + Property +composeIdentityLeft epochCase = + composeDelta deltaValue (identityDelta (sourceEndpointOf deltaValue)) === Right deltaValue + where + deltaValue = edcDelta epochCase + +composeIdentityRight :: + (EpochKeyed keyMap observed, Eq observed, Eq keyMap, Show observed, Show keyMap, Show (SetKey observed)) => + EpochDeltaCase keyMap observed -> + Property +composeIdentityRight epochCase = + composeDelta (identityDelta (targetEndpointOf deltaValue)) deltaValue === Right deltaValue + where + deltaValue = edcDelta epochCase + +composeAssociative :: + (EpochKeyed keyMap observed, Eq observed, Eq keyMap, Show observed, Show keyMap, Show (SetKey observed)) => + EpochChainCase keyMap observed -> + Property +composeAssociative chain = + leftAssociated === rightAssociated + where + older = eccFirst chain + middle = eccSecond chain + newer = eccThird chain + leftAssociated = + composeDelta middle older >>= composeDelta newer + rightAssociated = + composeDelta newer middle >>= (\newerMiddle -> composeDelta newerMiddle older) + +composeAgreesWithReference :: EpochPairCase (IntMap.IntMap Int) IntSet.IntSet -> Property +composeAgreesWithReference pairCase = + fmap referenceFromDelta (composeDelta newer older) + === referenceCompose (referenceFromDelta newer) (referenceFromDelta older) + where + older = epcFirst pairCase + newer = epcSecond pairCase + +composeDirtyTargetSequential :: EpochPairCase (IntMap.IntMap Int) IntSet.IntSet -> Property +composeDirtyTargetSequential pairCase = + case (composeDelta newer older, referenceCompose (referenceFromDelta newer) (referenceFromDelta older)) of + (Right composed, Right referenceComposed) -> + changedKeysAcrossEpoch composed === referenceChangedKeys referenceComposed + (Left err, _) -> + counterexample ("boundary-compatible composition failed: " <> show err) False + (_, Left err) -> + counterexample ("boundary-compatible reference failed: " <> show err) False + where + older = epcFirst pairCase + newer = epcSecond pairCase + +retireRecreateDirty :: Property +retireRecreateDirty = + case (epochDelta source middle IntMap.empty (IntSet.singleton 0) IntSet.empty, epochDelta middle target IntMap.empty IntSet.empty IntSet.empty) of + (Right older, Right newer) -> + fmap changedKeysAcrossEpoch (composeDelta newer older) + === Right (IntSet.singleton 0) + fixtures -> + counterexample ("valid retire/recreate fixtures rejected: " <> show fixtures) False + where + source = Endpoint (versionFromKey 0) (IntSet.singleton 0) + middle = Endpoint (versionFromKey 1) IntSet.empty + target = Endpoint (versionFromKey 2) (IntSet.singleton 0) + +renameIntoRetirement :: Property +renameIntoRetirement = + case (epochDelta source middle (IntMap.singleton 0 1) IntSet.empty IntSet.empty, epochDelta middle target IntMap.empty (IntSet.singleton 1) IntSet.empty) of + (Right older, Right newer) -> + case composeDelta newer older of + Left err -> + counterexample ("rename into retirement refused composition: " <> show err) False + Right composed -> + (retiredKeys composed, transportKeys composed (IntSet.singleton 0)) + === ( IntSet.singleton 0, + Transport IntMap.empty (IntSet.singleton 0) IntSet.empty + ) + fixtures -> + counterexample ("valid rename/retire fixtures rejected: " <> show fixtures) False + where + source = Endpoint (versionFromKey 0) (IntSet.singleton 0) + middle = Endpoint (versionFromKey 1) (IntSet.singleton 1) + target = Endpoint (versionFromKey 2) IntSet.empty diff --git a/test/epoch/ConstructionSpec.hs b/test/epoch/ConstructionSpec.hs new file mode 100644 --- /dev/null +++ b/test/epoch/ConstructionSpec.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module ConstructionSpec + ( constructionTests, + ) +where + +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet qualified as IntSet +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import EpochSupport.Generators +import EpochSupport.Types +import LawManifest (lawManifestCase, lawProperty) +import Moonlight.Core (IsLawName (..), OrdMap (..), OrdSet (..), SetKey, constructorLawName) +import Moonlight.Delta.Epoch +import Moonlight.Delta.Normalize (deltaNull) +import Test.QuickCheck (Property, (===), (.&&.)) +import Test.Tasty (TestTree, testGroup) + +data EpochDeltaConstructionLaw + = EpochDeltaRequiresVersionAdvance + | EpochDeltaRejectsTransportDomainEscape + | EpochDeltaRejectsTransportImageEscape + | EpochDeltaRejectsRetirementEscape + | EpochDeltaRejectsTransportForRetiredSource + | EpochDeltaRejectsUnmappedSurvivor + | EpochDeltaRejectsChangedOutsideSource + | EpochDeltaTransportIdentityFree + | EpochDeltaAllowsManyToOneTransport + | EpochDeltaFreshKeysDerivation + | EpochDeltaDirtyTargetDerivation + | EpochDeltaIdentityIsNull + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName EpochDeltaConstructionLaw where + lawNameText = constructorLawName . show + +constructionTests :: TestTree +constructionTests = + testGroup + "construction" + [ lawManifestCase "epoch delta construction" ([minBound .. maxBound] :: [EpochDeltaConstructionLaw]), + lawProperty EpochDeltaRequiresVersionAdvance sameVersionRejected, + lawProperty EpochDeltaRejectsTransportDomainEscape transportDomainEscapeRejected, + lawProperty EpochDeltaRejectsTransportImageEscape transportImageEscapeRejected, + lawProperty EpochDeltaRejectsRetirementEscape retirementEscapeRejected, + lawProperty EpochDeltaRejectsTransportForRetiredSource transportForRetiredSourceRejected, + lawProperty EpochDeltaRejectsUnmappedSurvivor unmappedSurvivorRejected, + lawProperty EpochDeltaRejectsChangedOutsideSource changedOutsideSourceRejected, + lawProperty EpochDeltaTransportIdentityFree transportIdentityFree, + lawProperty EpochDeltaAllowsManyToOneTransport manyToOneTransport, + lawProperty EpochDeltaFreshKeysDerivation $ + epochDeltaIntCaseProperty freshKeysDerivation + .&&. epochDeltaGenericCaseProperty freshKeysDerivation, + lawProperty EpochDeltaDirtyTargetDerivation $ + epochDeltaIntCaseProperty dirtyTargetDerivation + .&&. epochDeltaGenericCaseProperty dirtyTargetDerivation, + lawProperty EpochDeltaIdentityIsNull identityIsNull + ] + +sameVersionRejected :: Property +sameVersionRejected = + epochDelta endpoint endpoint IntMap.empty IntSet.empty IntSet.empty + === Left (VersionDidNotAdvance (versionFromKey 1) (versionFromKey 1)) + where + endpoint = Endpoint (versionFromKey 1) IntSet.empty + +transportDomainEscapeRejected :: Property +transportDomainEscapeRejected = + epochDelta source target (IntMap.singleton 0 1) IntSet.empty IntSet.empty + === Left (TransportDomainEscapesSource 0) + where + source = Endpoint (versionFromKey 1) IntSet.empty + target = Endpoint (versionFromKey 2) (IntSet.singleton 1) + +transportImageEscapeRejected :: Property +transportImageEscapeRejected = + epochDelta source target (IntMap.singleton 0 1) IntSet.empty IntSet.empty + === Left (TransportImageEscapesTarget 0 1) + where + source = Endpoint (versionFromKey 1) (IntSet.singleton 0) + target = Endpoint (versionFromKey 2) IntSet.empty + +retirementEscapeRejected :: Property +retirementEscapeRejected = + epochDelta source target IntMap.empty (IntSet.singleton 1) IntSet.empty + === Left (RetiredKeyOutsideSource 1) + where + source = Endpoint (versionFromKey 1) (IntSet.singleton 0) + target = Endpoint (versionFromKey 2) (IntSet.singleton 0) + +transportForRetiredSourceRejected :: Property +transportForRetiredSourceRejected = + epochDelta source target (IntMap.singleton 0 1) (IntSet.singleton 0) IntSet.empty + === Left (TransportDefinedForRetiredSource 0) + where + source = Endpoint (versionFromKey 1) (IntSet.singleton 0) + target = Endpoint (versionFromKey 2) (IntSet.singleton 1) + +unmappedSurvivorRejected :: Property +unmappedSurvivorRejected = + epochDelta source target IntMap.empty IntSet.empty IntSet.empty + === Left (SurvivingKeyOutsideTarget 0) + where + source = Endpoint (versionFromKey 1) (IntSet.singleton 0) + target = Endpoint (versionFromKey 2) IntSet.empty + +changedOutsideSourceRejected :: Property +changedOutsideSourceRejected = + epochDelta source target IntMap.empty IntSet.empty (IntSet.singleton 1) + === Left (ChangedKeyOutsideSource 1) + where + source = Endpoint (versionFromKey 1) (IntSet.singleton 0) + target = Endpoint (versionFromKey 2) (IntSet.singleton 0) + +transportIdentityFree :: Property +transportIdentityFree = + fmap transportOverrides (epochDelta source target (IntMap.fromList [(0, 0), (1, 2)]) IntSet.empty IntSet.empty) + === Right (IntMap.singleton 1 2) + where + source = Endpoint (versionFromKey 1) (IntSet.fromList [0, 1]) + target = Endpoint (versionFromKey 2) (IntSet.fromList [0, 2]) + +manyToOneTransport :: Property +manyToOneTransport = + fmap (\deltaValue -> transportKeys deltaValue querySourceKeys) (epochDelta source target transport IntSet.empty IntSet.empty) + === Right (Transport transport IntSet.empty IntSet.empty) + where + querySourceKeys = IntSet.fromList [0, 1] + source = Endpoint (versionFromKey 1) querySourceKeys + target = Endpoint (versionFromKey 2) (IntSet.singleton 2) + transport = IntMap.fromList [(0, 2), (1, 2)] + +freshKeysDerivation :: + (EpochKeyed keyMap observed, Eq observed, Show observed, Show keyMap, Show (SetKey observed)) => + EpochDeltaCase keyMap observed -> + Property +freshKeysDerivation epochCase = + freshKeys deltaValue + === differenceSet (targetKeys deltaValue) transportedTargetKeys + where + deltaValue = edcDelta epochCase + transportedTargetKeys = + fromListSet (fmap snd (toAscListMap (transportedKeys (transportKeys deltaValue (sourceKeys deltaValue))))) + +dirtyTargetDerivation :: + (EpochKeyed keyMap observed, Eq observed, Show observed, Show keyMap, Show (SetKey observed)) => + EpochDeltaCase keyMap observed -> + Property +dirtyTargetDerivation epochCase = + changedKeysAcrossEpoch deltaValue + === unionSet transportedChanged (freshKeys deltaValue) + where + input = edcInput epochCase + deltaValue = edcDelta epochCase + transportedChanged = + fromListSet (fmap snd (toAscListMap (transportedKeys (transportKeys deltaValue (eiChanged input))))) + +identityIsNull :: Property +identityIsNull = + deltaNull (identityDelta endpoint :: EpochDelta (Map.Map GenericKey GenericKey) (Set.Set GenericKey)) === True + where + endpoint = Endpoint (versionFromKey 3) (Set.singleton (GenericKey 0)) diff --git a/test/epoch/EpochSupport/Expected.hs b/test/epoch/EpochSupport/Expected.hs new file mode 100644 --- /dev/null +++ b/test/epoch/EpochSupport/Expected.hs @@ -0,0 +1,10 @@ +module EpochSupport.Expected + ( viewProjection, + ) +where + +import Moonlight.Delta.Epoch (ContextView (..), Version) + +viewProjection :: ContextView observed section -> (Version, observed, section) +viewProjection contextView = + (cvVersion contextView, cvObservedKeys contextView, cvSection contextView) diff --git a/test/epoch/EpochSupport/Generators.hs b/test/epoch/EpochSupport/Generators.hs new file mode 100644 --- /dev/null +++ b/test/epoch/EpochSupport/Generators.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module EpochSupport.Generators where + +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Moonlight.Delta.Epoch +import EpochSupport.Types +import Test.QuickCheck + ( Gen, + Property, + chooseInt, + elements, + forAll, + listOf, + sublistOf, + suchThatMap, + ) + +contextProjectionDeltaIntGen :: Gen (ContextProjectionDelta IntSet) +contextProjectionDeltaIntGen = + ContextProjectionDelta <$> intSetGen <*> intSetGen + +contextProjectionCarrierIntGen :: Gen (ContextProjectionDelta Int) +contextProjectionCarrierIntGen = + ContextProjectionDelta <$> chooseInt (-16, 16) <*> chooseInt (-16, 16) + +contextProjectionDeltaGenericGen :: Gen (ContextProjectionDelta GenericSet) +contextProjectionDeltaGenericGen = + ContextProjectionDelta <$> genericSetGen <*> genericSetGen + +projectionIntProperty :: (ContextProjectionDelta IntSet -> Property) -> Property +projectionIntProperty law = + forAll contextProjectionDeltaIntGen law + +projectionGenericProperty :: (ContextProjectionDelta GenericSet -> Property) -> Property +projectionGenericProperty law = + forAll contextProjectionDeltaGenericGen law + +projectionIntPairProperty :: + ((ContextProjectionDelta IntSet, ContextProjectionDelta IntSet) -> Property) -> + Property +projectionIntPairProperty law = + forAll ((,) <$> contextProjectionDeltaIntGen <*> contextProjectionDeltaIntGen) law + +projectionGenericPairProperty :: + ((ContextProjectionDelta GenericSet, ContextProjectionDelta GenericSet) -> Property) -> + Property +projectionGenericPairProperty law = + forAll ((,) <$> contextProjectionDeltaGenericGen <*> contextProjectionDeltaGenericGen) law + +projectionIntTripleProperty :: + ((ContextProjectionDelta IntSet, ContextProjectionDelta IntSet, ContextProjectionDelta IntSet) -> Property) -> + Property +projectionIntTripleProperty law = + forAll ((,,) <$> contextProjectionDeltaIntGen <*> contextProjectionDeltaIntGen <*> contextProjectionDeltaIntGen) law + +projectionGenericTripleProperty :: + ((ContextProjectionDelta GenericSet, ContextProjectionDelta GenericSet, ContextProjectionDelta GenericSet) -> Property) -> + Property +projectionGenericTripleProperty law = + forAll ((,,) <$> contextProjectionDeltaGenericGen <*> contextProjectionDeltaGenericGen <*> contextProjectionDeltaGenericGen) law + +viewIntGen :: Gen (ContextView IntSet Int) +viewIntGen = + viewAt <$> epochVersionSmallGen <*> intSetGen <*> chooseInt (-16, 16) + +viewGenericGen :: Gen (ContextView GenericSet Int) +viewGenericGen = + viewAt <$> epochVersionSmallGen <*> genericSetGen <*> chooseInt (-16, 16) + +viewIntProperty :: (ContextView IntSet Int -> Property) -> Property +viewIntProperty law = + forAll viewIntGen law + +viewGenericProperty :: (ContextView GenericSet Int -> Property) -> Property +viewGenericProperty law = + forAll viewGenericGen law + +epochVersionPairIntViewGen :: Gen (Version, ContextView IntSet Int) +epochVersionPairIntViewGen = + (,) <$> epochVersionSmallGen <*> viewIntGen + +epochVersionPairGenericViewGen :: Gen (Version, ContextView GenericSet Int) +epochVersionPairGenericViewGen = + (,) <$> epochVersionSmallGen <*> viewGenericGen + +epochDeltaIntGen :: Gen (EpochDelta (IntMap Int) IntSet) +epochDeltaIntGen = + edcDelta <$> epochDeltaIntCaseGen + +epochDeltaIntCaseGen :: Gen (EpochDeltaCase (IntMap Int) IntSet) +epochDeltaIntCaseGen = + suchThatMap epochInputIntGen mintEpochCase + +epochDeltaGenericCaseGen :: Gen (EpochDeltaCase GenericMap GenericSet) +epochDeltaGenericCaseGen = + suchThatMap epochInputGenericGen mintEpochCase + +epochDeltaIntCaseProperty :: (EpochDeltaCase (IntMap Int) IntSet -> Property) -> Property +epochDeltaIntCaseProperty law = + forAll epochDeltaIntCaseGen law + +epochDeltaGenericCaseProperty :: (EpochDeltaCase GenericMap GenericSet -> Property) -> Property +epochDeltaGenericCaseProperty law = + forAll epochDeltaGenericCaseGen law + +epochPairIntGen :: Gen (EpochPairCase (IntMap Int) IntSet) +epochPairIntGen = + compatiblePairGen intSetGen transportProposalIntGen intSubsetOf + +stableEpochPairIntGen :: Gen (EpochPairCase (IntMap Int) IntSet) +stableEpochPairIntGen = + stablePairGen intSetGen transportProposalIntGen intSubsetOf + +stableEpochChainIntGen :: Gen (EpochChainCase (IntMap Int) IntSet) +stableEpochChainIntGen = + stableChainGen intSetGen transportProposalIntGen intSubsetOf + +stableEpochPairGenericGen :: Gen (EpochPairCase GenericMap GenericSet) +stableEpochPairGenericGen = + stablePairGen genericSetGen transportProposalGenericGen genericSubsetOf + +stableEpochChainGenericGen :: Gen (EpochChainCase GenericMap GenericSet) +stableEpochChainGenericGen = + stableChainGen genericSetGen transportProposalGenericGen genericSubsetOf + +epochInputIntGen :: Gen (EpochInput (IntMap Int) IntSet) +epochInputIntGen = do + sourceVersionKey <- chooseInt (0, 32) + targetVersionKey <- chooseInt (sourceVersionKey + 1, sourceVersionKey + 4) + sourceKeySet <- intSetGen + targetKeySet <- intSetGen + (transport, retired) <- transportProposalIntGen sourceKeySet targetKeySet + changed <- intSubsetOf sourceKeySet + pure + EpochInput + { eiSource = Endpoint (versionFromKey (fromIntegral sourceVersionKey)) sourceKeySet, + eiTarget = Endpoint (versionFromKey (fromIntegral targetVersionKey)) targetKeySet, + eiTransport = transport, + eiRetired = retired, + eiChanged = changed + } + +epochInputGenericGen :: Gen (EpochInput GenericMap GenericSet) +epochInputGenericGen = do + sourceVersionKey <- chooseInt (0, 32) + targetVersionKey <- chooseInt (sourceVersionKey + 1, sourceVersionKey + 4) + sourceKeySet <- genericSetGen + targetKeySet <- genericSetGen + (transport, retired) <- transportProposalGenericGen sourceKeySet targetKeySet + changed <- genericSubsetOf sourceKeySet + pure + EpochInput + { eiSource = Endpoint (versionFromKey (fromIntegral sourceVersionKey)) sourceKeySet, + eiTarget = Endpoint (versionFromKey (fromIntegral targetVersionKey)) targetKeySet, + eiTransport = transport, + eiRetired = retired, + eiChanged = changed + } + +mintEpochCase :: + EpochKeyed keyMap observed => + EpochInput keyMap observed -> + Maybe (EpochDeltaCase keyMap observed) +mintEpochCase input = + case epochDelta (eiSource input) (eiTarget input) (eiTransport input) (eiRetired input) (eiChanged input) of + Left _err -> + Nothing + Right deltaValue -> + Just + EpochDeltaCase + { edcInput = input, + edcDelta = deltaValue + } + +compatiblePairGen :: + (EpochKeyed keyMap observed, Show observed) => + Gen observed -> + (observed -> observed -> Gen (keyMap, observed)) -> + (observed -> Gen observed) -> + Gen (EpochPairCase keyMap observed) +compatiblePairGen observedGen rekeyGen subsetGen = do + sourceKeySet <- observedGen + middleKeys <- observedGen + targetKeySet <- observedGen + first <- deltaBetweenGen (versionFromKey 0) (versionFromKey 1) sourceKeySet middleKeys rekeyGen subsetGen + second <- deltaBetweenGen (versionFromKey 1) (versionFromKey 2) middleKeys targetKeySet rekeyGen subsetGen + pure (EpochPairCase first second) + +stablePairGen :: + (EpochKeyed keyMap observed, Show observed) => + Gen observed -> + (observed -> observed -> Gen (keyMap, observed)) -> + (observed -> Gen observed) -> + Gen (EpochPairCase keyMap observed) +stablePairGen observedGen rekeyGen subsetGen = do + keysValue <- observedGen + first <- deltaBetweenGen (versionFromKey 0) (versionFromKey 1) keysValue keysValue rekeyGen subsetGen + second <- deltaBetweenGen (versionFromKey 1) (versionFromKey 2) keysValue keysValue rekeyGen subsetGen + pure (EpochPairCase first second) + +stableChainGen :: + (EpochKeyed keyMap observed, Show observed) => + Gen observed -> + (observed -> observed -> Gen (keyMap, observed)) -> + (observed -> Gen observed) -> + Gen (EpochChainCase keyMap observed) +stableChainGen observedGen rekeyGen subsetGen = do + keysValue <- observedGen + first <- deltaBetweenGen (versionFromKey 0) (versionFromKey 1) keysValue keysValue rekeyGen subsetGen + second <- deltaBetweenGen (versionFromKey 1) (versionFromKey 2) keysValue keysValue rekeyGen subsetGen + third <- deltaBetweenGen (versionFromKey 2) (versionFromKey 3) keysValue keysValue rekeyGen subsetGen + pure (EpochChainCase first second third) + +deltaBetweenGen :: + (EpochKeyed keyMap observed, Show observed) => + Version -> + Version -> + observed -> + observed -> + (observed -> observed -> Gen (keyMap, observed)) -> + (observed -> Gen observed) -> + Gen (EpochDelta keyMap observed) +deltaBetweenGen sourceVersionValue targetVersionValue sourceKeySet targetKeySet transportGen subsetGen = + suchThatMap inputGen (fmap edcDelta . mintEpochCase) + where + inputGen = do + (transport, retired) <- transportGen sourceKeySet targetKeySet + changed <- subsetGen sourceKeySet + pure + EpochInput + { eiSource = Endpoint sourceVersionValue sourceKeySet, + eiTarget = Endpoint targetVersionValue targetKeySet, + eiTransport = transport, + eiRetired = retired, + eiChanged = changed + } + +intSetGen :: Gen IntSet +intSetGen = + IntSet.fromList <$> listOf (chooseInt (0, 16)) + +genericSetGen :: Gen GenericSet +genericSetGen = + Set.fromList <$> listOf genericKeyGen + +genericKeyGen :: Gen GenericKey +genericKeyGen = + GenericKey <$> chooseInt (0, 16) + +epochVersionSmallGen :: Gen Version +epochVersionSmallGen = + versionFromKey . fromIntegral <$> chooseInt (0, 16) + +intSubsetOf :: IntSet -> Gen IntSet +intSubsetOf keysValue = + IntSet.fromList <$> sublistOf (IntSet.toAscList keysValue) + +genericSubsetOf :: GenericSet -> Gen GenericSet +genericSubsetOf keysValue = + Set.fromList <$> sublistOf (Set.toAscList keysValue) + +transportProposalIntGen :: IntSet -> IntSet -> Gen (IntMap Int, IntSet) +transportProposalIntGen sourceKeySet targetKeySet = + case IntSet.toAscList targetKeySet of + [] -> + pure (IntMap.empty, sourceKeySet) + targetList -> do + retired <- IntSet.fromList <$> sublistOf (IntSet.toAscList sourceKeySet) + let surviving = IntSet.difference sourceKeySet retired + chosenEntries <- traverse (\sourceKey -> (sourceKey,) <$> elements targetList) (IntSet.toAscList surviving) + pure (IntMap.fromList chosenEntries, retired) + +transportProposalGenericGen :: GenericSet -> GenericSet -> Gen (GenericMap, GenericSet) +transportProposalGenericGen sourceKeySet targetKeySet = + case Set.toAscList targetKeySet of + [] -> + pure (Map.empty, sourceKeySet) + targetList -> do + retired <- Set.fromList <$> sublistOf (Set.toAscList sourceKeySet) + let surviving = Set.difference sourceKeySet retired + chosenEntries <- traverse (\sourceKey -> (sourceKey,) <$> elements targetList) (Set.toAscList surviving) + pure (Map.fromList chosenEntries, retired) diff --git a/test/epoch/EpochSupport/Mapping.hs b/test/epoch/EpochSupport/Mapping.hs new file mode 100644 --- /dev/null +++ b/test/epoch/EpochSupport/Mapping.hs @@ -0,0 +1,57 @@ +module EpochSupport.Mapping where + +import Data.IntSet (IntSet) +import Moonlight.Delta.Epoch +import EpochSupport.Types + +mapProjectionInt :: + (Int -> Int) -> + ContextProjectionDelta IntSet -> + ContextProjectionDelta IntSet +mapProjectionInt = + mapContextProjectionDelta + +mapProjectionGeneric :: + (GenericKey -> GenericKey) -> + ContextProjectionDelta GenericSet -> + ContextProjectionDelta GenericSet +mapProjectionGeneric = + mapContextProjectionDelta + +mapViewInt :: + (Int -> Int) -> + ContextView IntSet section -> + ContextView IntSet section +mapViewInt = + mapContextViewKeys + +mapViewGeneric :: + (GenericKey -> GenericKey) -> + ContextView GenericSet section -> + ContextView GenericSet section +mapViewGeneric = + mapContextViewKeys + +identityInt :: Int -> Int +identityInt value = + value + +doubleInt :: Int -> Int +doubleInt value = + value * 2 + +incrementInt :: Int -> Int +incrementInt value = + value + 1 + +identityGenericKey :: GenericKey -> GenericKey +identityGenericKey key = + key + +genericDouble :: GenericKey -> GenericKey +genericDouble (GenericKey value) = + GenericKey (value * 2) + +genericIncrement :: GenericKey -> GenericKey +genericIncrement (GenericKey value) = + GenericKey (value + 1) diff --git a/test/epoch/EpochSupport/Reference.hs b/test/epoch/EpochSupport/Reference.hs new file mode 100644 --- /dev/null +++ b/test/epoch/EpochSupport/Reference.hs @@ -0,0 +1,173 @@ +module EpochSupport.Reference + ( EpochReference (..), + referenceFromInput, + referenceFromDelta, + referenceTransportKeys, + referenceChangedKeys, + referenceRetiredKeys, + referenceTransportView, + referenceCompose, + ) +where + +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet +import Data.Maybe (catMaybes) +import Moonlight.Delta.Epoch +import EpochSupport.Types (EpochInput (..)) + +-- | A deliberately denormalized sequential oracle. Every source key owns an +-- explicit 'Maybe' target, so composition is ordinary Kleisli composition of +-- partial functions rather than a copy of the production sparse formula. +data EpochReference = EpochReference + { erSourceVersion :: !Version, + erTargetVersion :: !Version, + erSourceKeys :: !IntSet, + erTargetKeys :: !IntSet, + erMovement :: !(IntMap (Maybe Int)), + erDirtyTargetKeys :: !IntSet + } + deriving stock (Eq, Show) + +-- | Lower an accepted constructor input into the deliberately denormalized +-- oracle without consulting any production transport observer. +referenceFromInput :: EpochInput (IntMap Int) IntSet -> EpochReference +referenceFromInput input = + EpochReference + { erSourceVersion = endpointVersion (eiSource input), + erTargetVersion = endpointVersion (eiTarget input), + erSourceKeys = sourceKeySet, + erTargetKeys = targetKeySet, + erMovement = movement, + erDirtyTargetKeys = IntSet.union transportedChanged freshTargetKeys + } + where + sourceKeySet = endpointKeys (eiSource input) + targetKeySet = endpointKeys (eiTarget input) + movement = + IntMap.fromAscList + [ ( sourceKey, + if IntSet.member sourceKey (eiRetired input) + then Nothing + else Just (IntMap.findWithDefault sourceKey sourceKey (eiTransport input)) + ) + | sourceKey <- IntSet.toAscList sourceKeySet + ] + freshTargetKeys = + IntSet.difference targetKeySet (IntSet.fromList (catMaybes (IntMap.elems movement))) + transportedChanged = + IntSet.fromList + [ targetKey + | sourceKey <- IntSet.toAscList (eiChanged input), + Just (Just targetKey) <- [IntMap.lookup sourceKey movement] + ] + +referenceFromDelta :: EpochDelta (IntMap Int) IntSet -> EpochReference +referenceFromDelta deltaValue = + EpochReference + { erSourceVersion = sourceVersion deltaValue, + erTargetVersion = targetVersion deltaValue, + erSourceKeys = sourceKeys deltaValue, + erTargetKeys = targetKeys deltaValue, + erMovement = + IntMap.fromList + ( fmap (fmap Just) (IntMap.toAscList (transportedKeys transportResult)) + <> fmap (,Nothing) (IntSet.toAscList (transportRetiredKeys transportResult)) + ), + erDirtyTargetKeys = changedKeysAcrossEpoch deltaValue + } + where + transportResult = + transportKeys deltaValue (sourceKeys deltaValue) + +referenceTransportKeys :: EpochReference -> IntSet -> Transport (IntMap Int) IntSet +referenceTransportKeys reference queryKeys = + Transport + { transportedKeys = + IntMap.fromList + [ (sourceKey, targetKey) + | sourceKey <- IntSet.toAscList knownKeys, + Just (Just targetKey) <- [IntMap.lookup sourceKey (erMovement reference)] + ], + transportRetiredKeys = + IntSet.fromList + [ sourceKey + | sourceKey <- IntSet.toAscList knownKeys, + Just Nothing <- [IntMap.lookup sourceKey (erMovement reference)] + ], + transportUnknownKeys = + IntSet.difference queryKeys (erSourceKeys reference) + } + where + knownKeys = + IntSet.intersection queryKeys (erSourceKeys reference) + +referenceChangedKeys :: EpochReference -> IntSet +referenceChangedKeys = + erDirtyTargetKeys + +referenceRetiredKeys :: EpochReference -> IntSet +referenceRetiredKeys reference = + IntSet.fromList + [ sourceKey + | (sourceKey, Nothing) <- IntMap.toAscList (erMovement reference) + ] + +referenceTransportView :: + EpochReference -> + ContextView IntSet section -> + Either (ViewTransportError Int) (ContextView IntSet section) +referenceTransportView reference contextView + | cvVersion contextView /= erSourceVersion reference = + Left (ViewSourceVersionMismatch (erSourceVersion reference) (cvVersion contextView)) + | otherwise = + case IntSet.toAscList (transportUnknownKeys transportResult) of + unknownKey : _ -> + Left (ViewObservedKeyUnknown unknownKey) + [] -> + Right + ( viewWithVersion + (erTargetVersion reference) + (viewWithSupport (IntSet.fromList (IntMap.elems (transportedKeys transportResult))) contextView) + ) + where + transportResult = + referenceTransportKeys reference (cvObservedKeys contextView) + +referenceCompose :: + EpochReference -> + EpochReference -> + Either (ComposeError Int) EpochReference +referenceCompose newer older + | erTargetVersion older /= erSourceVersion newer = + Left (ComposeVersionMismatch (erTargetVersion older) (erSourceVersion newer)) + | erTargetKeys older /= erSourceKeys newer = + Left ComposeUniverseMismatch + | otherwise = + Right + EpochReference + { erSourceVersion = erSourceVersion older, + erTargetVersion = erTargetVersion newer, + erSourceKeys = erSourceKeys older, + erTargetKeys = erTargetKeys newer, + erMovement = IntMap.map composeMovement (erMovement older), + erDirtyTargetKeys = + IntSet.union + (transportDirtyThroughReference newer (erDirtyTargetKeys older)) + (erDirtyTargetKeys newer) + } + where + composeMovement Nothing = + Nothing + composeMovement (Just intermediateKey) = + IntMap.findWithDefault Nothing intermediateKey (erMovement newer) + +transportDirtyThroughReference :: EpochReference -> IntSet -> IntSet +transportDirtyThroughReference reference dirtyKeys = + IntSet.fromList + [ targetKey + | dirtyKey <- IntSet.toAscList dirtyKeys, + Just (Just targetKey) <- [IntMap.lookup dirtyKey (erMovement reference)] + ] diff --git a/test/epoch/EpochSupport/Types.hs b/test/epoch/EpochSupport/Types.hs new file mode 100644 --- /dev/null +++ b/test/epoch/EpochSupport/Types.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TypeFamilies #-} + +module EpochSupport.Types where + +import Data.Map.Strict (Map) +import Data.Set (Set) +import Moonlight.Delta.Epoch + +newtype GenericKey = GenericKey Int + deriving stock (Eq, Ord, Show) + +type GenericMap = Map GenericKey GenericKey + +type GenericSet = Set GenericKey + +data EpochInput keyMap observed = EpochInput + { eiSource :: !(Endpoint observed), + eiTarget :: !(Endpoint observed), + eiTransport :: !keyMap, + eiRetired :: !observed, + eiChanged :: !observed + } + deriving stock (Eq, Show) + +data EpochDeltaCase keyMap observed = EpochDeltaCase + { edcInput :: !(EpochInput keyMap observed), + edcDelta :: !(EpochDelta keyMap observed) + } + deriving stock (Eq, Show) + +data EpochPairCase keyMap observed = EpochPairCase + { epcFirst :: !(EpochDelta keyMap observed), + epcSecond :: !(EpochDelta keyMap observed) + } + deriving stock (Eq, Show) + +data EpochChainCase keyMap observed = EpochChainCase + { eccFirst :: !(EpochDelta keyMap observed), + eccSecond :: !(EpochDelta keyMap observed), + eccThird :: !(EpochDelta keyMap observed) + } + deriving stock (Eq, Show) diff --git a/test/epoch/EpochTests.hs b/test/epoch/EpochTests.hs new file mode 100644 --- /dev/null +++ b/test/epoch/EpochTests.hs @@ -0,0 +1,34 @@ +module EpochTests + ( contextProjectionCarrierIntGen, + contextProjectionDeltaIntGen, + epochDeltaIntGen, + tests, + ) +where + +import ComposeSpec (composeTests) +import ConstructionSpec (constructionTests) +import FiniteSpec (finiteTests) +import EpochSupport.Generators + ( contextProjectionCarrierIntGen, + contextProjectionDeltaIntGen, + epochDeltaIntGen, + ) +import ProjectionSpec (projectionTests) +import TransportSpec (transportTests) +import VersionSpec (versionTests) +import ViewSpec (viewTests) +import Test.Tasty (TestTree, testGroup) + +tests :: TestTree +tests = + testGroup + "epoch" + [ versionTests, + projectionTests, + viewTests, + constructionTests, + transportTests, + composeTests, + finiteTests + ] diff --git a/test/epoch/FiniteSpec.hs b/test/epoch/FiniteSpec.hs new file mode 100644 --- /dev/null +++ b/test/epoch/FiniteSpec.hs @@ -0,0 +1,177 @@ +module FiniteSpec + ( finiteTests, + ) +where + +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet +import Data.Maybe (catMaybes) +import Moonlight.Delta.Epoch +import EpochSupport.Generators (mintEpochCase) +import EpochSupport.Reference +import EpochSupport.Types +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) + +finiteTests :: TestTree +finiteTests = + testGroup + "finite exhaustive" + [ testCase "finite five-key transports match the reference" $ + finiteTransportMismatches @?= [], + testCase "finite three-key compositions match the reference" $ + finiteComposeMismatches @?= [], + testCase "finite three-key associativity holds" $ + finiteAssociativityMismatches @?= [] + ] +finiteTransportMismatches :: + [ ( Transport (IntMap Int) IntSet, + Transport (IntMap Int) IntSet, + IntSet, + IntSet + ) + ] +finiteTransportMismatches = + take + 1 + [ (actualTransport, expectedTransport, actualChanged, expectedChanged) + | epochCase <- finiteDeltas finiteFiveKeys, + let deltaValue = edcDelta epochCase, + let reference = referenceFromInput (edcInput epochCase), + queryKeys <- finiteIntSets finiteFiveKeys, + let actualTransport = transportKeys deltaValue queryKeys, + let expectedTransport = referenceTransportKeys reference queryKeys, + let actualChanged = changedKeysAcrossEpoch deltaValue, + let expectedChanged = referenceChangedKeys reference, + actualTransport /= expectedTransport || actualChanged /= expectedChanged + ] + +finiteComposeMismatches :: + [ ( Either (ComposeError Int) EpochReference, + Either (ComposeError Int) EpochReference + ) + ] +finiteComposeMismatches = + take + 1 + [ (actual, expected) + | firstCase <- finiteDeltas finiteThreeKeys, + let first = edcDelta firstCase, + secondCase <- finiteDeltas finiteThreeKeys, + let second = edcDelta secondCase, + targetVersion first == sourceVersion second, + targetKeys first == sourceKeys second, + let actual = referenceFromDelta <$> composeDelta second first, + let expected = referenceCompose (referenceFromDelta second) (referenceFromDelta first), + actual /= expected + ] + +finiteAssociativityMismatches :: + [ ( Either (ComposeError Int) EpochReference, + Either (ComposeError Int) EpochReference + ) + ] +finiteAssociativityMismatches = + take + 1 + [ (fmap referenceFromDelta leftAssociated, fmap referenceFromDelta rightAssociated) + | firstCase <- finiteStableDeltas finiteThreeKeys (versionFromKey 0) (versionFromKey 1), + let first = edcDelta firstCase, + secondCase <- finiteStableDeltas finiteThreeKeys (versionFromKey 1) (versionFromKey 2), + let second = edcDelta secondCase, + thirdCase <- finiteStableDeltas finiteThreeKeys (versionFromKey 2) (versionFromKey 3), + let third = edcDelta thirdCase, + let leftAssociated = + composeDelta second first + >>= composeDelta third, + let rightAssociated = + composeDelta third second + >>= \thirdSecond -> composeDelta thirdSecond first, + fmap referenceFromDelta leftAssociated /= fmap referenceFromDelta rightAssociated + ] + +finiteDeltas :: [Int] -> [EpochDeltaCase (IntMap Int) IntSet] +finiteDeltas universeKeys = + [ deltaValue + | sourceKeySet <- finiteIntSets universeKeys, + targetKeySet <- finiteIntSets universeKeys, + (transport, retired) <- finiteTransports sourceKeySet targetKeySet, + changedKeys <- finiteChangedBasis sourceKeySet, + let input = + EpochInput + { eiSource = Endpoint (versionFromKey 0) sourceKeySet, + eiTarget = Endpoint (versionFromKey 1) targetKeySet, + eiTransport = transport, + eiRetired = retired, + eiChanged = changedKeys + }, + Just deltaValue <- [mintEpochCase input] + ] + +finiteStableDeltas :: + [Int] -> + Version -> + Version -> + [EpochDeltaCase (IntMap Int) IntSet] +finiteStableDeltas universeKeys sourceVersionValue targetVersionValue = + [ deltaValue + | keysValue <- finiteIntSets universeKeys, + (transport, retired) <- finiteTransports keysValue keysValue, + changedKeys <- finiteChangedBasis keysValue, + let input = + EpochInput + { eiSource = Endpoint sourceVersionValue keysValue, + eiTarget = Endpoint targetVersionValue keysValue, + eiTransport = transport, + eiRetired = retired, + eiChanged = changedKeys + }, + Just deltaValue <- [mintEpochCase input] + ] + +finiteTransports :: IntSet -> IntSet -> [(IntMap Int, IntSet)] +finiteTransports sourceKeySet targetKeySet = + fmap transportFromChoices (traverse choicesForSourceKey (IntSet.toAscList sourceKeySet)) + where + choicesForSourceKey sourceKey = + Nothing + : [ Just (sourceKey, targetKey) + | targetKey <- IntSet.toAscList targetKeySet + ] + + transportFromChoices choices = + ( IntMap.fromAscList (catMaybes choices), + IntSet.fromAscList + [ sourceKey + | (sourceKey, Nothing) <- zip (IntSet.toAscList sourceKeySet) choices + ] + ) + +finiteChangedBasis :: IntSet -> [IntSet] +finiteChangedBasis sourceKeySet = + IntSet.empty + : sourceKeySet + : fmap IntSet.singleton (IntSet.toAscList sourceKeySet) + +finiteIntSets :: [Int] -> [IntSet] +finiteIntSets universeKeys = + fmap IntSet.fromList (subsequencesList universeKeys) + +subsequencesList :: [a] -> [[a]] +subsequencesList values = + case values of + [] -> + [[]] + value : rest -> + let restSubsequences = subsequencesList rest + in restSubsequences <> fmap (value :) restSubsequences + +finiteFiveKeys :: [Int] +finiteFiveKeys = + [0 .. 4] + +finiteThreeKeys :: [Int] +finiteThreeKeys = + [0 .. 2] diff --git a/test/epoch/Main.hs b/test/epoch/Main.hs new file mode 100644 --- /dev/null +++ b/test/epoch/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified EpochTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain EpochTests.tests diff --git a/test/epoch/ProjectionSpec.hs b/test/epoch/ProjectionSpec.hs new file mode 100644 --- /dev/null +++ b/test/epoch/ProjectionSpec.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module ProjectionSpec + ( projectionTests, + ) +where + +import Data.IntSet (IntSet) +import Moonlight.Core + ( IsLawName (..), + OrdSet (..), + constructorLawName, + ) +import Moonlight.Delta.Epoch +import EpochSupport.Generators +import EpochSupport.Mapping +import EpochSupport.Types +import Moonlight.Delta.Normalize +import Moonlight.Delta.Support +import LawManifest + ( lawManifestCase, + lawProperty, + ) +import Test.QuickCheck + ( Property, + (===), + (.&&.), + ) +import Test.Tasty (TestTree, testGroup) + +data EpochProjectionLaw + = EpochProjectionUnionAssociative + | EpochProjectionUnionCommutative + | EpochProjectionUnionIdempotent + | EpochProjectionEmptyUnit + | EpochProjectionMapIdentity + | EpochProjectionMapComposition + | EpochProjectionMapSemilatticeHomomorphism + | EpochProjectionNullIffComponentsEmpty + | EpochProjectionNormalizeCanonicalCarrier + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName EpochProjectionLaw where + lawNameText = + constructorLawName . show + +projectionTests :: TestTree +projectionTests = + testGroup + "projection" + [ lawManifestCase "epoch projection" ([minBound .. maxBound] :: [EpochProjectionLaw]), + lawProperty EpochProjectionUnionAssociative $ + projectionIntTripleProperty projectionUnionAssociative + .&&. projectionGenericTripleProperty projectionUnionAssociative, + lawProperty EpochProjectionUnionCommutative $ + projectionIntPairProperty projectionUnionCommutative + .&&. projectionGenericPairProperty projectionUnionCommutative, + lawProperty EpochProjectionUnionIdempotent $ + projectionIntProperty projectionUnionIdempotent + .&&. projectionGenericProperty projectionUnionIdempotent, + lawProperty EpochProjectionEmptyUnit $ + projectionIntProperty projectionEmptyUnit + .&&. projectionGenericProperty projectionEmptyUnit, + lawProperty EpochProjectionMapIdentity $ + projectionIntProperty projectionMapIdentityInt + .&&. projectionGenericProperty projectionMapIdentityGeneric, + lawProperty EpochProjectionMapComposition $ + projectionIntProperty projectionMapCompositionInt + .&&. projectionGenericProperty projectionMapCompositionGeneric, + lawProperty EpochProjectionMapSemilatticeHomomorphism $ + projectionIntPairProperty projectionMapSemilatticeHomomorphismInt + .&&. projectionGenericPairProperty projectionMapSemilatticeHomomorphismGeneric, + lawProperty EpochProjectionNullIffComponentsEmpty $ + projectionIntProperty projectionNullIffComponentsEmpty + .&&. projectionGenericProperty projectionNullIffComponentsEmpty, + lawProperty EpochProjectionNormalizeCanonicalCarrier $ + projectionIntProperty projectionNormalizeCanonicalCarrier + .&&. projectionGenericProperty projectionNormalizeCanonicalCarrier + ] +projectionUnionAssociative :: + (Eq observed, Show observed, OrdSet observed) => + (ContextProjectionDelta observed, ContextProjectionDelta observed, ContextProjectionDelta observed) -> + Property +projectionUnionAssociative (left, middle, right) = + left <> (middle <> right) === (left <> middle) <> right + +projectionUnionCommutative :: + (Eq observed, Show observed, OrdSet observed) => + (ContextProjectionDelta observed, ContextProjectionDelta observed) -> + Property +projectionUnionCommutative (left, right) = + left <> right === right <> left + +projectionUnionIdempotent :: + (Eq observed, Show observed, OrdSet observed) => + ContextProjectionDelta observed -> + Property +projectionUnionIdempotent deltaValue = + deltaValue <> deltaValue === deltaValue + +projectionEmptyUnit :: + (Eq observed, Show observed, OrdSet observed) => + ContextProjectionDelta observed -> + Property +projectionEmptyUnit deltaValue = + (emptyContextProjectionDelta <> deltaValue, deltaValue <> emptyContextProjectionDelta) + === (deltaValue, deltaValue) + +projectionMapIdentityInt :: ContextProjectionDelta IntSet -> Property +projectionMapIdentityInt deltaValue = + mapProjectionInt identityInt deltaValue === deltaValue + +projectionMapIdentityGeneric :: ContextProjectionDelta GenericSet -> Property +projectionMapIdentityGeneric deltaValue = + mapProjectionGeneric identityGenericKey deltaValue === deltaValue + +projectionMapCompositionInt :: ContextProjectionDelta IntSet -> Property +projectionMapCompositionInt deltaValue = + mapProjectionInt (incrementInt . doubleInt) deltaValue + === mapProjectionInt incrementInt (mapProjectionInt doubleInt deltaValue) + +projectionMapCompositionGeneric :: ContextProjectionDelta GenericSet -> Property +projectionMapCompositionGeneric deltaValue = + mapProjectionGeneric (genericIncrement . genericDouble) deltaValue + === mapProjectionGeneric genericIncrement (mapProjectionGeneric genericDouble deltaValue) + +projectionMapSemilatticeHomomorphismInt :: + (ContextProjectionDelta IntSet, ContextProjectionDelta IntSet) -> + Property +projectionMapSemilatticeHomomorphismInt (left, right) = + mapProjectionInt incrementInt (left <> right) + === mapProjectionInt incrementInt left <> mapProjectionInt incrementInt right + +projectionMapSemilatticeHomomorphismGeneric :: + (ContextProjectionDelta GenericSet, ContextProjectionDelta GenericSet) -> + Property +projectionMapSemilatticeHomomorphismGeneric (left, right) = + mapProjectionGeneric genericIncrement (left <> right) + === mapProjectionGeneric genericIncrement left <> mapProjectionGeneric genericIncrement right + +projectionNullIffComponentsEmpty :: + (Eq observed, Show observed, OrdSet observed) => + ContextProjectionDelta observed -> + Property +projectionNullIffComponentsEmpty deltaValue = + nullContextProjectionDelta deltaValue + === (nullSet (dirtyBaseKeys deltaValue) && nullSet (dirtyResultKeys deltaValue)) + +projectionNormalizeCanonicalCarrier :: + ( Eq observed, + Show observed, + OrdSet observed, + Eq (ContextProjectionDelta observed), + Show (ContextProjectionDelta observed) + ) => + ContextProjectionDelta observed -> + Property +projectionNormalizeCanonicalCarrier deltaValue = + ( normalizeContextProjectionDelta deltaValue, + normalizeDelta deltaValue, + deltaSupport (normalizeDelta deltaValue), + deltaNull (normalizeDelta deltaValue) + ) + === ( deltaValue, + deltaValue, + deltaSupport deltaValue, + deltaNull deltaValue + ) diff --git a/test/epoch/TransportSpec.hs b/test/epoch/TransportSpec.hs new file mode 100644 --- /dev/null +++ b/test/epoch/TransportSpec.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module TransportSpec + ( transportTests, + ) +where + +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet qualified as IntSet +import EpochSupport.Expected (viewProjection) +import EpochSupport.Generators +import EpochSupport.Reference +import EpochSupport.Types +import LawManifest (lawManifestCase, lawProperty) +import Moonlight.Core (IsLawName (..), OrdMap (..), OrdSet (..), SetKey, constructorLawName) +import Moonlight.Delta.Epoch +import Test.QuickCheck (Gen, Property, counterexample, forAll, (===), (.&&.)) +import Test.Tasty (TestTree, testGroup) + +data TransportLaw + = TransportPartitionsQuery + | TransportTargetsBelongToEndpoint + | TransportAgreesWithSequentialReference + | EpochViewTransportSourceVersionGuard + | EpochViewTransportDropsRetiredKeys + | EpochViewTransportTargetsValid + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName TransportLaw where + lawNameText = constructorLawName . show + +transportTests :: TestTree +transportTests = + testGroup + "transport" + [ lawManifestCase "epoch transport" ([minBound .. maxBound] :: [TransportLaw]), + lawProperty TransportPartitionsQuery $ + epochDeltaIntCaseProperty (transportPartitionsQuery intSetGen) + .&&. epochDeltaGenericCaseProperty (transportPartitionsQuery genericSetGen), + lawProperty TransportTargetsBelongToEndpoint $ + epochDeltaIntCaseProperty (transportTargetsBelongToEndpoint intSetGen) + .&&. epochDeltaGenericCaseProperty (transportTargetsBelongToEndpoint genericSetGen), + lawProperty TransportAgreesWithSequentialReference $ + forAll epochDeltaIntCaseGen transportAgreesWithReference, + lawProperty EpochViewTransportSourceVersionGuard viewTransportSourceVersionGuard, + lawProperty EpochViewTransportDropsRetiredKeys viewTransportDropsRetiredKeys, + lawProperty EpochViewTransportTargetsValid $ + epochDeltaIntCaseProperty (viewTransportTargetsValid intSubsetOf) + .&&. epochDeltaGenericCaseProperty (viewTransportTargetsValid genericSubsetOf) + ] + +transportPartitionsQuery :: + (EpochKeyed keyMap observed, Eq observed, Show observed, Show keyMap, Show (SetKey observed)) => + Gen observed -> + EpochDeltaCase keyMap observed -> + Property +transportPartitionsQuery queryGen epochCase = + forAll queryGen $ \queryKeys -> + let result = transportKeys deltaValue queryKeys + transportedDomain = fromListSet (fmap fst (toAscListMap (transportedKeys result))) + retired = transportRetiredKeys result + unknown = transportUnknownKeys result + in counterexample ("transport result: " <> show result) $ + ( unionsSet [transportedDomain, retired, unknown], + intersectionSet transportedDomain retired, + intersectionSet transportedDomain unknown, + intersectionSet retired unknown + ) + === (queryKeys, emptySet, emptySet, emptySet) + where + deltaValue = edcDelta epochCase + +transportTargetsBelongToEndpoint :: + (EpochKeyed keyMap observed, Eq observed, Show observed, Show keyMap, Show (SetKey observed)) => + Gen observed -> + EpochDeltaCase keyMap observed -> + Property +transportTargetsBelongToEndpoint queryGen epochCase = + forAll queryGen $ \queryKeys -> + let result = transportKeys deltaValue queryKeys + targetImages = fromListSet (fmap snd (toAscListMap (transportedKeys result))) + in intersectionSet targetImages (targetKeys deltaValue) === targetImages + where + deltaValue = edcDelta epochCase + +transportAgreesWithReference :: EpochDeltaCase (IntMap.IntMap Int) IntSet.IntSet -> Property +transportAgreesWithReference epochCase = + forAll intSetGen $ \queryKeys -> + transportKeys deltaValue queryKeys + === referenceTransportKeys (referenceFromInput (edcInput epochCase)) queryKeys + where + deltaValue = edcDelta epochCase + +viewTransportSourceVersionGuard :: Property +viewTransportSourceVersionGuard = + case epochDelta source target IntMap.empty IntSet.empty IntSet.empty of + Left err -> + counterexample ("valid view fixture rejected: " <> show err) False + Right deltaValue -> + transportView deltaValue (viewAt (versionFromKey 0) (IntSet.singleton 1) ()) + === Left (ViewSourceVersionMismatch (versionFromKey 1) (versionFromKey 0)) + where + source = Endpoint (versionFromKey 1) (IntSet.singleton 1) + target = Endpoint (versionFromKey 2) (IntSet.singleton 1) + +viewTransportDropsRetiredKeys :: Property +viewTransportDropsRetiredKeys = + case epochDelta source target IntMap.empty (IntSet.singleton 1) IntSet.empty of + Left err -> + counterexample ("valid retirement fixture rejected: " <> show err) False + Right deltaValue -> + fmap viewProjection (transportView deltaValue (viewAt (versionFromKey 1) (IntSet.singleton 1) ())) + === Right (versionFromKey 2, IntSet.empty, ()) + where + source = Endpoint (versionFromKey 1) (IntSet.singleton 1) + target = Endpoint (versionFromKey 2) IntSet.empty + +viewTransportTargetsValid :: + (EpochKeyed keyMap observed, Eq observed, Show observed, Show keyMap, Show (SetKey observed)) => + (observed -> Gen observed) -> + EpochDeltaCase keyMap observed -> + Property +viewTransportTargetsValid subsetGen epochCase = + forAll (subsetGen (sourceKeys deltaValue)) $ \observedKeys -> + case transportView deltaValue (viewAt (sourceVersion deltaValue) observedKeys ()) of + Left err -> + counterexample ("source-contained view transport failed: " <> show err) False + Right transportedView -> + intersectionSet (cvObservedKeys transportedView) (targetKeys deltaValue) + === cvObservedKeys transportedView + where + deltaValue = edcDelta epochCase diff --git a/test/epoch/VersionSpec.hs b/test/epoch/VersionSpec.hs new file mode 100644 --- /dev/null +++ b/test/epoch/VersionSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DerivingStrategies #-} + +module VersionSpec + ( versionTests, + ) +where + +import LawManifest (lawManifestCase, lawProperty) +import Moonlight.Core (IsLawName (..), PartialOrder (..), constructorLawName) +import Moonlight.Delta.Epoch +import Test.QuickCheck (Arbitrary (..), Property, (===)) +import Test.Tasty (TestTree, testGroup) + +newtype EpochKey = EpochKey Integer + deriving stock (Eq, Show) + +instance Arbitrary EpochKey where + arbitrary = EpochKey <$> arbitrary + shrink (EpochKey value) = EpochKey <$> shrink value + +data VersionLaw + = VersionInitialKey + | VersionKeyRoundTrip + | VersionNextKeySuccessor + | VersionNextStrictlyAdvances + | VersionLeqAgreesWithKeyOrder + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName VersionLaw where + lawNameText = constructorLawName . show + +versionTests :: TestTree +versionTests = + testGroup + "version" + [ lawManifestCase "epoch version" ([minBound .. maxBound] :: [VersionLaw]), + lawProperty VersionInitialKey $ versionKey initialVersion === 0, + lawProperty VersionKeyRoundTrip $ \(EpochKey key) -> versionKey (versionFromKey key) === key, + lawProperty VersionNextKeySuccessor $ \(EpochKey key) -> versionKey (nextVersion (versionFromKey key)) === key + 1, + lawProperty VersionNextStrictlyAdvances $ nextStrictlyAdvances, + lawProperty VersionLeqAgreesWithKeyOrder $ \(EpochKey leftKey) (EpochKey rightKey) -> + leq (versionFromKey leftKey) (versionFromKey rightKey) === (leftKey <= rightKey) + ] + +nextStrictlyAdvances :: EpochKey -> Property +nextStrictlyAdvances (EpochKey key) = + (leq versionValue nextValue && versionValue /= nextValue) === True + where + versionValue = versionFromKey key + nextValue = nextVersion versionValue diff --git a/test/epoch/ViewSpec.hs b/test/epoch/ViewSpec.hs new file mode 100644 --- /dev/null +++ b/test/epoch/ViewSpec.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DerivingStrategies #-} + +module ViewSpec + ( viewTests, + ) +where + +import Data.IntSet (IntSet) +import Moonlight.Core + ( IsLawName (..), + constructorLawName, + ) +import Moonlight.Delta.Epoch +import EpochSupport.Generators +import EpochSupport.Mapping +import EpochSupport.Types +import LawManifest + ( lawManifestCase, + lawProperty, + ) +import Test.QuickCheck + ( Property, + forAll, + (===), + (.&&.), + ) +import Test.Tasty (TestTree, testGroup) + +data EpochViewLaw + = EpochViewMapKeysIdentity + | EpochViewMapKeysComposition + | EpochViewCurrentIffVersionEqual + | EpochViewStaleComplement + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName EpochViewLaw where + lawNameText = + constructorLawName . show + +viewTests :: TestTree +viewTests = + testGroup + "view" + [ lawManifestCase "epoch view" ([minBound .. maxBound] :: [EpochViewLaw]), + lawProperty EpochViewMapKeysIdentity $ + viewIntProperty viewMapKeysIdentityInt + .&&. viewGenericProperty viewMapKeysIdentityGeneric, + lawProperty EpochViewMapKeysComposition $ + viewIntProperty viewMapKeysCompositionInt + .&&. viewGenericProperty viewMapKeysCompositionGeneric, + lawProperty EpochViewCurrentIffVersionEqual $ + forAll epochVersionPairIntViewGen viewCurrentIffVersionEqual + .&&. forAll epochVersionPairGenericViewGen viewCurrentIffVersionEqual, + lawProperty EpochViewStaleComplement $ + forAll epochVersionPairIntViewGen viewStaleComplement + .&&. forAll epochVersionPairGenericViewGen viewStaleComplement + ] +viewMapKeysIdentityInt :: ContextView IntSet Int -> Property +viewMapKeysIdentityInt contextView = + mapViewInt identityInt contextView === contextView + +viewMapKeysIdentityGeneric :: ContextView GenericSet Int -> Property +viewMapKeysIdentityGeneric contextView = + mapViewGeneric identityGenericKey contextView === contextView + +viewMapKeysCompositionInt :: ContextView IntSet Int -> Property +viewMapKeysCompositionInt contextView = + mapViewInt (incrementInt . doubleInt) contextView + === mapViewInt incrementInt (mapViewInt doubleInt contextView) + +viewMapKeysCompositionGeneric :: ContextView GenericSet Int -> Property +viewMapKeysCompositionGeneric contextView = + mapViewGeneric (genericIncrement . genericDouble) contextView + === mapViewGeneric genericIncrement (mapViewGeneric genericDouble contextView) + +viewCurrentIffVersionEqual :: + (Version, ContextView observed Int) -> + Property +viewCurrentIffVersionEqual (epochVersion, contextView) = + contextViewIsCurrent epochVersion contextView + === (epochVersion == cvVersion contextView) + +viewStaleComplement :: + (Version, ContextView observed Int) -> + Property +viewStaleComplement (epochVersion, contextView) = + contextViewIsStale epochVersion contextView + === not (contextViewIsCurrent epochVersion contextView) diff --git a/test/laws/CrossCarrierLaws.hs b/test/laws/CrossCarrierLaws.hs new file mode 100644 --- /dev/null +++ b/test/laws/CrossCarrierLaws.hs @@ -0,0 +1,77 @@ +module CrossCarrierLaws + ( tests, + ) +where + +import Data.IntSet qualified as IntSet +import Data.Map.Strict qualified as Map +import DeltaLaws (deltaNormalizeLaws, deltaSupportLaws, functorLaws) +import EpochSupport.Generators + ( contextProjectionCarrierIntGen, + contextProjectionDeltaIntGen, + ) +import Moonlight.Delta.Epoch (emptyContextProjectionDelta) +import Moonlight.Delta.Scope +import Moonlight.Delta.Signed +import PatchSupport (patchDeltaGen) +import Test.QuickCheck (Gen, chooseInt, listOf, oneof) +import Test.Tasty (TestTree, testGroup) + +tests :: TestTree +tests = + testGroup + "laws" + [ normalizeTests, + supportTests, + functorLaws "ContextProjectionDelta" contextProjectionCarrierIntGen + ] + +normalizeTests :: TestTree +normalizeTests = + testGroup + "normalize" + [ deltaNormalizeLaws "signed" signedDeltaGen, + deltaNormalizeLaws "patch" patchDeltaGen, + deltaNormalizeLaws "scope" scopedDeltaGen, + deltaNormalizeLaws "context projection" contextProjectionDeltaIntGen + ] + +supportTests :: TestTree +supportTests = + testGroup + "support" + [ deltaSupportLaws "signed" signedDeltaGen (pure emptySigned), + deltaSupportLaws "scope" scopedDeltaGen (pure cleanDelta), + deltaSupportLaws "context projection" contextProjectionDeltaIntGen (pure emptyContextProjectionDelta) + ] + +intSetGen :: Gen IntSet.IntSet +intSetGen = + IntSet.fromList <$> listOf (chooseInt (0, 16)) + +maybeIntSetGen :: Gen (Maybe IntSet.IntSet) +maybeIntSetGen = + oneof + [ pure Nothing, + Just <$> intSetGen + ] + +deltaScopeGen :: Gen (Scope IntSet.IntSet) +deltaScopeGen = + oneof + [ pure cleanScope, + dirtyScope <$> intSetGen, + pure fullScope + ] + +scopedDeltaGen :: Gen (Scoped IntSet.IntSet IntSet.IntSet) +scopedDeltaGen = + Scoped <$> deltaScopeGen <*> maybeIntSetGen + +signedDeltaGen :: Gen (Signed Int) +signedDeltaGen = + signedFromChangeMap . Map.fromList <$> listOf signedMultiplicityChangeEntryGen + +signedMultiplicityChangeEntryGen :: Gen (Int, MultiplicityChange) +signedMultiplicityChangeEntryGen = + (,) <$> chooseInt (0, 16) <*> (MultiplicityChange . fromIntegral <$> chooseInt (-16, 16)) diff --git a/test/laws/Main.hs b/test/laws/Main.hs new file mode 100644 --- /dev/null +++ b/test/laws/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified CrossCarrierLaws +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain CrossCarrierLaws.tests diff --git a/test/patch/CodecSpec.hs b/test/patch/CodecSpec.hs new file mode 100644 --- /dev/null +++ b/test/patch/CodecSpec.hs @@ -0,0 +1,144 @@ +module CodecSpec + ( codecTests, + ) +where + +import Data.Map.Strict qualified as Map +import Moonlight.Delta.Patch +import Moonlight.Delta.Patch.Internal.Builder (toPaged) +import Moonlight.Delta.Patch.Internal.Types (CodecStats (..), debugCodecStats) +import Moonlight.Delta.Patch.Internal.Types qualified as Internal +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, (@?=), testCase) + +codecTests :: TestTree +codecTests = + testGroup + "codec" + [ testCase "constructor packs repeated endpoints as constant columns" $ + debugCodecStats repeatedEndpointPatch + @?= + CodecStats + { codecExplicitKeyColumns = 0, + codecRangeKeyColumns = 1, + codecAffineKeyColumns = 0, + codecAbsentColumns = 0, + codecConstantColumns = 2, + codecRunColumns = 0, + codecAffineValueColumns = 0, + codecDenseColumns = 0 + }, + testCase "constructor packs repeated endpoint runs as run columns" $ + debugCodecStats runEndpointPatch + @?= + CodecStats + { codecExplicitKeyColumns = 0, + codecRangeKeyColumns = 1, + codecAffineKeyColumns = 0, + codecAbsentColumns = 0, + codecConstantColumns = 0, + codecRunColumns = 2, + codecAffineValueColumns = 0, + codecDenseColumns = 0 + }, + testCase "constructor packs strided Int support as affine key columns" $ + debugCodecStats affineKeyPatch + @?= + CodecStats + { codecExplicitKeyColumns = 0, + codecRangeKeyColumns = 0, + codecAffineKeyColumns = 1, + codecAbsentColumns = 0, + codecConstantColumns = 2, + codecRunColumns = 0, + codecAffineValueColumns = 0, + codecDenseColumns = 0 + }, + testCase "constructor keeps non-Int support in explicit key columns" $ + debugCodecStats genericKeyPatch + @?= + CodecStats + { codecExplicitKeyColumns = 1, + codecRangeKeyColumns = 0, + codecAffineKeyColumns = 0, + codecAbsentColumns = 0, + codecConstantColumns = 2, + codecRunColumns = 0, + codecAffineValueColumns = 0, + codecDenseColumns = 0 + }, + testCase "constructor packs strided Int endpoints as affine value columns" $ + debugCodecStats affineValuePatch + @?= + CodecStats + { codecExplicitKeyColumns = 0, + codecRangeKeyColumns = 1, + codecAffineKeyColumns = 0, + codecAbsentColumns = 0, + codecConstantColumns = 0, + codecRunColumns = 0, + codecAffineValueColumns = 2, + codecDenseColumns = 0 + }, + testCase "normalization downshifts an under-threshold paged patch" $ + case Internal.normalize (toPaged smallPatch) of + Internal.SmallPatch _cells -> pure () + Internal.PagedPatch _count _pages -> assertFailure "under-threshold patch remained paged", + testCase "diff returns the canonical small representation" $ + case diff (Map.empty :: Map.Map Int String) Map.empty of + Internal.SmallPatch _cells -> pure () + Internal.PagedPatch _count _pages -> assertFailure "empty diff remained paged" + ] + +repeatedEndpointPatch :: Patch Int String +repeatedEndpointPatch = + fromAscList + [ (key, replace "before" "after") + | key <- [0 .. 63] + ] + +runEndpointPatch :: Patch Int String +runEndpointPatch = + fromAscList + [ (key, replace (beforeValue key) (afterValue key)) + | key <- [0 .. 63] + ] + where + beforeValue :: Int -> String + beforeValue key = + if key < 32 then "before-left" else "before-right" + + afterValue :: Int -> String + afterValue key = + if key < 32 then "after-left" else "after-right" + +affineKeyPatch :: Patch Int String +affineKeyPatch = + fromAscList + [ (key, replace "before" "after") + | key <- fmap (* 2) [0 .. 63] + ] + +newtype GenericCodecKey = GenericCodecKey Int + deriving stock (Eq, Ord) + +genericKeyPatch :: Patch GenericCodecKey String +genericKeyPatch = + fromAscList + [ (GenericCodecKey key, replace "before" "after") + | key <- [0 .. 63] + ] + +affineValuePatch :: Patch Int Int +affineValuePatch = + fromAscList + [ (key, replace (key * 2) (key * 2 + 1)) + | key <- [0 .. 63] + ] + +smallPatch :: Patch Int String +smallPatch = + fromAscList + [ (key, replace "before" "after") + | key <- [0 .. 7] + ] diff --git a/test/patch/DeltaHashSpec.hs b/test/patch/DeltaHashSpec.hs new file mode 100644 --- /dev/null +++ b/test/patch/DeltaHashSpec.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE DerivingStrategies #-} + +module DeltaHashSpec + ( deltaHashTests, + ) +where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Moonlight.Core + ( StableHashEncoding, + stableHashEncodingWord64LE, + ) +import Moonlight.Delta.Patch + ( ApplyError (..), + DeltaHashApplyError (..), + DeltaHashBuildError (..), + DeltaHashDigest (..), + Digest128, + MerkleDeltaHash, + MultisetDeltaHash, + ) +import Moonlight.Delta.Patch qualified as Patch +import Test.QuickCheck + ( Gen, + Property, + chooseInt, + counterexample, + forAll, + listOf, + (===), + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), assertFailure, testCase) +import Test.Tasty.QuickCheck (testProperty) + +deltaHashTests :: TestTree +deltaHashTests = + testGroup + "delta hash" + [ testProperty "Merkle patch agrees with rebuild" merklePatchAgreesWithRebuild, + testProperty "Merkle edit history descends to one root" merkleHistoryDescendsToCanonicalRoot, + testProperty "multiset patch agrees with rebuild" multisetPatchAgreesWithRebuild, + testProperty "multiset disjoint union composes through the patch action" multisetDisjointUnionHomomorphism, + testProperty "multiset insertion and deletion are additive inverses" multisetAdditiveInverse, + testProperty "multiset disjoint edit order is history-independent" multisetOrderIndependence, + testCase "Merkle crosses the adaptive boundary in both directions" adaptiveBoundaryCase, + testCase "all four cell edits update both strategies" cellEditsCase, + testCase "stale patch rejection is preserved on both strategies" stalePatchCase, + testCase "equal key representatives rebuild on both strategies" representativeRewriteCase, + testCase "equal value representatives rebuild on both strategies" valueRepresentativeRewriteCase, + testCase "flat mode admits localized path collisions" flatModeCollisionCase, + testCase "Merkle construction reports one localized path collision" constructionCollisionCase, + testCase "Merkle insertion reports a localized path collision atomically" updateCollisionCase, + testCase "128-bit digest construction matches protocol goldens" digestGoldenCase + ] + +merklePatchAgreesWithRebuild :: Property +merklePatchAgreesWithRebuild = + forAll smallMapGen $ \beforeState -> + forAll smallMapGen $ \afterState -> + case (buildTestMerkleDeltaHash beforeState, buildTestMerkleDeltaHash afterState) of + (Right beforeDeltaHash, Right rebuiltDeltaHash) -> + fmap + merkleObservation + (Patch.applyMerkleDeltaHash (Patch.diff beforeState afterState) beforeDeltaHash) + === Right (merkleObservation rebuiltDeltaHash) + (Left obstruction, _) -> + counterexample ("unexpected initial key collision: " <> show obstruction) False + (_, Left obstruction) -> + counterexample ("unexpected rebuilt key collision: " <> show obstruction) False + +merkleHistoryDescendsToCanonicalRoot :: Property +merkleHistoryDescendsToCanonicalRoot = + forAll smallMapGen $ \middleState -> + forAll smallMapGen $ \finalState -> + case (buildTestMerkleDeltaHash Map.empty, buildTestMerkleDeltaHash finalState) of + (Right emptyDeltaHash, Right rebuiltDeltaHash) -> + let descended = do + middleDeltaHash <- + Patch.applyMerkleDeltaHash + (Patch.diff Map.empty middleState) + emptyDeltaHash + Patch.applyMerkleDeltaHash + (Patch.diff middleState finalState) + middleDeltaHash + in fmap merkleObservation descended + === Right (merkleObservation rebuiltDeltaHash) + (Left obstruction, _) -> + counterexample ("unexpected empty Merkle failure: " <> show obstruction) False + (_, Left obstruction) -> + counterexample ("unexpected final key collision: " <> show obstruction) False + +multisetPatchAgreesWithRebuild :: Property +multisetPatchAgreesWithRebuild = + forAll smallMapGen $ \beforeState -> + forAll smallMapGen $ \afterState -> + let beforeDeltaHash = buildTestMultisetDeltaHash beforeState + rebuiltDeltaHash = buildTestMultisetDeltaHash afterState + in fmap + multisetObservation + (Patch.applyMultisetDeltaHash (Patch.diff beforeState afterState) beforeDeltaHash) + === Right (multisetObservation rebuiltDeltaHash) + +multisetDisjointUnionHomomorphism :: Property +multisetDisjointUnionHomomorphism = + forAll smallMapGen $ \authoritativeState -> + let (leftState, rightState) = + Map.partitionWithKey (\key _value -> even key) authoritativeState + combinedState = Map.union leftState rightState + combinedByAction = + Patch.applyMultisetDeltaHash + (Patch.diff Map.empty rightState) + (buildTestMultisetDeltaHash leftState) + in fmap multisetObservation combinedByAction + === Right (multisetObservation (buildTestMultisetDeltaHash combinedState)) + +multisetAdditiveInverse :: Property +multisetAdditiveInverse = + forAll smallMapGen $ \authoritativeState -> + let freshKey = 4096 + freshValue = 17 + initialDeltaHash = buildTestMultisetDeltaHash authoritativeState + roundTrip = do + insertedDeltaHash <- + Patch.applyMultisetDeltaHash + (Patch.singleton freshKey (Patch.insert freshValue)) + initialDeltaHash + Patch.applyMultisetDeltaHash + (Patch.singleton freshKey (Patch.delete freshValue)) + insertedDeltaHash + in fmap multisetObservation roundTrip + === Right (multisetObservation initialDeltaHash) + +multisetOrderIndependence :: Property +multisetOrderIndependence = + forAll smallMapGen $ \authoritativeState -> + let (leftState, rightState) = + Map.partitionWithKey (\key _value -> even key) authoritativeState + leftPatch = Patch.diff Map.empty leftState + rightPatch = Patch.diff Map.empty rightState + emptyDeltaHash = buildTestMultisetDeltaHash Map.empty + leftThenRight = do + leftDeltaHash <- Patch.applyMultisetDeltaHash leftPatch emptyDeltaHash + Patch.applyMultisetDeltaHash rightPatch leftDeltaHash + rightThenLeft = do + rightDeltaHash <- Patch.applyMultisetDeltaHash rightPatch emptyDeltaHash + Patch.applyMultisetDeltaHash leftPatch rightDeltaHash + expectedObservation = + multisetObservation (buildTestMultisetDeltaHash authoritativeState) + in (fmap multisetObservation leftThenRight, fmap multisetObservation rightThenLeft) + === (Right expectedObservation, Right expectedObservation) + +adaptiveBoundaryCase :: IO () +adaptiveBoundaryCase = do + let boundaryState = sequentialState deltaHashFlatBoundarySize + insertedKey = deltaHashFlatBoundarySize + expandedState = Map.insert insertedKey insertedKey boundaryState + boundaryDeltaHash <- requireRight (buildTestMerkleDeltaHash boundaryState) + expandedDeltaHash <- + requireRight + ( Patch.applyMerkleDeltaHash + (Patch.singleton insertedKey (Patch.insert insertedKey)) + boundaryDeltaHash + ) + rebuiltExpandedDeltaHash <- requireRight (buildTestMerkleDeltaHash expandedState) + merkleObservation expandedDeltaHash + @?= merkleObservation rebuiltExpandedDeltaHash + contractedDeltaHash <- + requireRight + ( Patch.applyMerkleDeltaHash + (Patch.singleton insertedKey (Patch.delete insertedKey)) + expandedDeltaHash + ) + merkleObservation contractedDeltaHash + @?= merkleObservation boundaryDeltaHash + +cellEditsCase :: IO () +cellEditsCase = do + let initialState = Map.fromList [(1, 10), (2, 20)] + expectedState = Map.fromList [(1, 11), (3, 30)] + patchValue = + Patch.fromList + [ (1, Patch.replace 10 11), + (2, Patch.delete 20), + (3, Patch.insert 30), + (4, Patch.assertAbsent) + ] + initialMerkleDeltaHash <- requireRight (buildTestMerkleDeltaHash initialState) + updatedMerkleDeltaHash <- + requireRight (Patch.applyMerkleDeltaHash patchValue initialMerkleDeltaHash) + rebuiltMerkleDeltaHash <- requireRight (buildTestMerkleDeltaHash expectedState) + merkleObservation updatedMerkleDeltaHash + @?= merkleObservation rebuiltMerkleDeltaHash + updatedMultisetDeltaHash <- + requireRight + ( Patch.applyMultisetDeltaHash + patchValue + (buildTestMultisetDeltaHash initialState) + ) + multisetObservation updatedMultisetDeltaHash + @?= multisetObservation (buildTestMultisetDeltaHash expectedState) + +stalePatchCase :: IO () +stalePatchCase = do + let initialState = Map.singleton 1 10 + patchValue = Patch.singleton 1 (Patch.replace 9 11) + expectedObstruction = + DeltaHashPatchRejected + ApplyBeforeMismatch + { mismatchKey = 1, + expectedBefore = Just 9, + actualBefore = Just 10 + } + initialMerkleDeltaHash <- requireRight (buildTestMerkleDeltaHash initialState) + case Patch.applyMerkleDeltaHash patchValue initialMerkleDeltaHash of + Left obstruction -> + obstruction @?= expectedObstruction + Right _deltaHash -> + assertFailure "expected stale Merkle patch to be rejected" + case Patch.applyMultisetDeltaHash patchValue (buildTestMultisetDeltaHash initialState) of + Left obstruction -> + obstruction @?= expectedObstruction + Right _deltaHash -> + assertFailure "expected stale multiset patch to be rejected" + +representativeRewriteCase :: IO () +representativeRewriteCase = do + let stateEntry key = + (RepresentativeKey key StateRepresentative, key * 10) + expectedEntry key + | key == 1 = (RepresentativeKey key PatchRepresentative, 11) + | otherwise = stateEntry key + keys = [1 .. deltaHashFlatBoundarySize + 1] + initialState = Map.fromDistinctAscList (fmap stateEntry keys) + expectedState = Map.fromDistinctAscList (fmap expectedEntry keys) + patchKey = RepresentativeKey 1 PatchRepresentative + patchValue = Patch.singleton patchKey (Patch.replace 10 11) + initialMerkleDeltaHash <- + requireRight + (Patch.buildMerkleDeltaHash representativeKeyEncoding intEncoding initialState) + updatedMerkleDeltaHash <- + requireRight (Patch.applyMerkleDeltaHash patchValue initialMerkleDeltaHash) + rebuiltMerkleDeltaHash <- + requireRight + (Patch.buildMerkleDeltaHash representativeKeyEncoding intEncoding expectedState) + Patch.merkleDeltaHashDigest updatedMerkleDeltaHash + @?= Patch.merkleDeltaHashDigest rebuiltMerkleDeltaHash + fmap (representativeKind . fst) (Map.lookupGE patchKey (Patch.merkleDeltaHashState updatedMerkleDeltaHash)) + @?= Just PatchRepresentative + let initialMultisetDeltaHash = + Patch.buildMultisetDeltaHash representativeKeyEncoding intEncoding initialState + rebuiltMultisetDeltaHash = + Patch.buildMultisetDeltaHash representativeKeyEncoding intEncoding expectedState + updatedMultisetDeltaHash <- + requireRight (Patch.applyMultisetDeltaHash patchValue initialMultisetDeltaHash) + Patch.multisetDeltaHashDigest updatedMultisetDeltaHash + @?= Patch.multisetDeltaHashDigest rebuiltMultisetDeltaHash + fmap (representativeKind . fst) (Map.lookupGE patchKey (Patch.multisetDeltaHashState updatedMultisetDeltaHash)) + @?= Just PatchRepresentative + +valueRepresentativeRewriteCase :: IO () +valueRepresentativeRewriteCase = do + let stateValue = RepresentativeValue 10 StateRepresentative + patchBefore = RepresentativeValue 10 PatchRepresentative + patchAfter = RepresentativeValue 11 PatchRepresentative + initialState = Map.singleton 1 stateValue + expectedState = Map.singleton 1 patchAfter + patchValue = Patch.singleton 1 (Patch.replace patchBefore patchAfter) + initialMerkleDeltaHash <- + requireRight + (Patch.buildMerkleDeltaHash intEncoding representativeValueEncoding initialState) + updatedMerkleDeltaHash <- + requireRight (Patch.applyMerkleDeltaHash patchValue initialMerkleDeltaHash) + rebuiltMerkleDeltaHash <- + requireRight + (Patch.buildMerkleDeltaHash intEncoding representativeValueEncoding expectedState) + Patch.merkleDeltaHashDigest updatedMerkleDeltaHash + @?= Patch.merkleDeltaHashDigest rebuiltMerkleDeltaHash + let initialMultisetDeltaHash = + Patch.buildMultisetDeltaHash intEncoding representativeValueEncoding initialState + rebuiltMultisetDeltaHash = + Patch.buildMultisetDeltaHash intEncoding representativeValueEncoding expectedState + updatedMultisetDeltaHash <- + requireRight (Patch.applyMultisetDeltaHash patchValue initialMultisetDeltaHash) + Patch.multisetDeltaHashDigest updatedMultisetDeltaHash + @?= Patch.multisetDeltaHashDigest rebuiltMultisetDeltaHash + +flatModeCollisionCase :: IO () +flatModeCollisionCase = do + let authoritativeState = Map.fromList [(1, 10), (2, 20)] + deltaHashValue <- + requireRight + (Patch.buildMerkleDeltaHash constantEncoding intEncoding authoritativeState) + Patch.merkleDeltaHashState deltaHashValue @?= authoritativeState + +constructionCollisionCase :: IO () +constructionCollisionCase = + case + Patch.buildMerkleDeltaHash + boundaryCollisionEncoding + intEncoding + (sequentialState (deltaHashFlatBoundarySize + 1)) + of + Left DeltaHashKeyCollision {deltaHashExistingKey, deltaHashIncomingKey} -> + (deltaHashExistingKey, deltaHashIncomingKey) + @?= (0, deltaHashFlatBoundarySize) + Right _deltaHash -> + assertFailure "expected distinct keys with one digest path to be rejected" + +updateCollisionCase :: IO () +updateCollisionCase = do + let authoritativeState = sequentialState deltaHashFlatBoundarySize + incomingKey = deltaHashFlatBoundarySize + initialDeltaHash <- + requireRight + (Patch.buildMerkleDeltaHash boundaryCollisionEncoding intEncoding authoritativeState) + case + Patch.applyMerkleDeltaHash + (Patch.singleton incomingKey (Patch.insert incomingKey)) + initialDeltaHash + of + Left (DeltaHashUpdateRejected DeltaHashKeyCollision {}) -> + Patch.merkleDeltaHashState initialDeltaHash @?= authoritativeState + Left obstruction -> + assertFailure ("expected collision obstruction, received: " <> show obstruction) + Right _deltaHash -> + assertFailure "expected insertion collision to be rejected" + +digestGoldenCase :: IO () +digestGoldenCase = do + flatDeltaHash <- + requireRight (buildTestMerkleDeltaHash (Map.fromList [(1, 10), (2, 20)])) + Patch.merkleDeltaHashDigest flatDeltaHash + @?= DeltaHashDigest 0x897d1ee3ac05ae2f 0x24244b4e097f0dd5 + merkleDeltaHash <- + requireRight + (buildTestMerkleDeltaHash (sequentialState (deltaHashFlatBoundarySize + 1))) + Patch.merkleDeltaHashDigest merkleDeltaHash + @?= DeltaHashDigest 0x34c7f2a72e9f90b2 0xd725d3dd1caef993 + Patch.multisetDeltaHashDigest + (buildTestMultisetDeltaHash (Map.fromList [(1, 10), (2, 20)])) + @?= DeltaHashDigest 0xa3b63bd3bb34ff9e 0x2e36babb08d75d1e + +merkleObservation :: MerkleDeltaHash Int Int -> (Map Int Int, Digest128) +merkleObservation deltaHashValue = + (Patch.merkleDeltaHashState deltaHashValue, Patch.merkleDeltaHashDigest deltaHashValue) + +multisetObservation :: MultisetDeltaHash Int Int -> (Map Int Int, Digest128) +multisetObservation deltaHashValue = + (Patch.multisetDeltaHashState deltaHashValue, Patch.multisetDeltaHashDigest deltaHashValue) + +buildTestMerkleDeltaHash :: + Map Int Int -> + Either (DeltaHashBuildError Int) (MerkleDeltaHash Int Int) +buildTestMerkleDeltaHash = + Patch.buildMerkleDeltaHash intEncoding intEncoding + +buildTestMultisetDeltaHash :: Map Int Int -> MultisetDeltaHash Int Int +buildTestMultisetDeltaHash = + Patch.buildMultisetDeltaHash intEncoding intEncoding + +sequentialState :: Int -> Map Int Int +sequentialState stateSize = + Map.fromDistinctAscList (fmap (\key -> (key, key)) [0 .. stateSize - 1]) + +intEncoding :: Int -> StableHashEncoding +intEncoding = + stableHashEncodingWord64LE . fromIntegral + +boundaryCollisionEncoding :: Int -> StableHashEncoding +boundaryCollisionEncoding key + | key == deltaHashFlatBoundarySize = intEncoding 0 + | otherwise = intEncoding key + +constantEncoding :: Int -> StableHashEncoding +constantEncoding _value = + stableHashEncodingWord64LE 0 + +data RepresentativeKind + = StateRepresentative + | PatchRepresentative + deriving stock (Eq, Ord, Show) + +data RepresentativeKey = RepresentativeKey + { representativeId :: !Int, + representativeKind :: !RepresentativeKind + } + deriving stock (Show) + +instance Eq RepresentativeKey where + left == right = + representativeId left == representativeId right + +instance Ord RepresentativeKey where + compare left right = + compare (representativeId left) (representativeId right) + +representativeKeyEncoding :: RepresentativeKey -> StableHashEncoding +representativeKeyEncoding representative = + intEncoding (representativeId representative) + <> representativeKindEncoding (representativeKind representative) + +data RepresentativeValue = RepresentativeValue + { representativeValueId :: !Int, + representativeValueKind :: !RepresentativeKind + } + deriving stock (Show) + +instance Eq RepresentativeValue where + left == right = + representativeValueId left == representativeValueId right + +representativeValueEncoding :: RepresentativeValue -> StableHashEncoding +representativeValueEncoding representative = + intEncoding (representativeValueId representative) + <> representativeKindEncoding (representativeValueKind representative) + +representativeKindEncoding :: RepresentativeKind -> StableHashEncoding +representativeKindEncoding representative = + stableHashEncodingWord64LE + ( case representative of + StateRepresentative -> 0 + PatchRepresentative -> 1 + ) + +smallMapGen :: Gen (Map Int Int) +smallMapGen = + Map.fromList <$> listOf ((,) <$> chooseInt (-32, 32) <*> chooseInt (-1000, 1000)) + +deltaHashFlatBoundarySize :: Int +deltaHashFlatBoundarySize = + 256 + +requireRight :: Show obstruction => Either obstruction value -> IO value +requireRight result = + case result of + Left obstruction -> + assertFailure (show obstruction) + Right value -> + pure value diff --git a/test/patch/LawsSpec.hs b/test/patch/LawsSpec.hs new file mode 100644 --- /dev/null +++ b/test/patch/LawsSpec.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DerivingStrategies #-} + +module LawsSpec + ( lawTests, + ) +where + +import Data.Foldable qualified as Foldable +import Data.Set qualified as Set +import Moonlight.Core (IsLawName (..), constructorLawName) +import PatchLaws + ( patchLaws, + ) +import Moonlight.Delta.Patch +import Moonlight.Delta.Patch qualified as Patch +import PatchSupport +import LawManifest + ( lawManifestCase, + lawProperty, + ) +import Test.QuickCheck + ( Property, + counterexample, + forAll, + (===), + ) +import Test.Tasty (TestTree, testGroup) + +data PatchFacadeLaw + = PatchFacadeComposeIdentity + | PatchFacadeComposeAssociativityMultiKey + | PatchFacadeApplyComposeHomomorphismMultiKey + | PatchFacadeSupportToAscList + | PatchFacadeLookupToAscListCoherence + | PatchFacadeRecordManyCoherence + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName PatchFacadeLaw where + lawNameText = + constructorLawName . show + +lawTests :: TestTree +lawTests = + testGroup + "laws" + [ patchLaws "single-cell patch" patchDeltaGen patchChainGen patchStaleCaseGen, + lawManifestCase "patch facade" ([minBound .. maxBound] :: [PatchFacadeLaw]), + lawProperty PatchFacadeComposeIdentity $ + forAll patchDeltaGen patchComposeIdentity, + lawProperty PatchFacadeComposeAssociativityMultiKey $ + forAll patchFacadeChainGen patchComposeAssociativityMultiKey, + lawProperty PatchFacadeApplyComposeHomomorphismMultiKey $ + forAll patchFacadeChainGen patchApplyComposeHomomorphismMultiKey, + lawProperty PatchFacadeSupportToAscList $ + forAll patchDeltaGen patchSupportToAscList, + lawProperty PatchFacadeLookupToAscListCoherence $ + forAll patchDeltaGen patchLookupToAscListCoherence, + lawProperty PatchFacadeRecordManyCoherence $ + forAll patchAppliedEditListGen patchRecordManyCoherence + ] + +patchComposeIdentity :: Patch Int String -> Property +patchComposeIdentity patch = + (compose emptyPatch patch, compose patch emptyPatch) + === (Right patch, Right patch) + where + emptyPatch :: Patch Int String + emptyPatch = + empty + +patchComposeAssociativityMultiKey :: PatchFacadeChain -> Property +patchComposeAssociativityMultiKey chain = + (compose p3 =<< compose p2 p1) + === (flip compose p1 =<< compose p3 p2) + where + p1 = + diff (pfcState0 chain) (pfcState1 chain) + p2 = + diff (pfcState1 chain) (pfcState2 chain) + p3 = + diff (pfcState2 chain) (pfcState3 chain) + +patchApplyComposeHomomorphismMultiKey :: PatchFacadeChain -> Property +patchApplyComposeHomomorphismMultiKey chain = + case compose p2 p1 of + Left err -> + counterexample ("compatible multi-key patch chain refused composition: " <> show err) False + Right composed -> + apply composed (pfcState0 chain) === Right (pfcState2 chain) + where + p1 = + diff (pfcState0 chain) (pfcState1 chain) + p2 = + diff (pfcState1 chain) (pfcState2 chain) + +patchSupportToAscList :: Patch Int String -> Property +patchSupportToAscList patch = + support patch === Set.fromList (fst <$> toAscList patch) + +patchLookupToAscListCoherence :: Patch Int String -> Property +patchLookupToAscListCoherence patch = + (presentLookups, absentLookups) + === (expectedPresentLookups, expectedAbsentLookups) + where + rows = + toAscList patch + presentLookups = + [(key, Patch.lookup key patch) | (key, _cell) <- rows] + expectedPresentLookups = + [(key, Just cell) | (key, cell) <- rows] + presentKeys = + Set.fromList (fst <$> rows) + absentKeys = + take 3 [key | key <- [-1 .. 17], Set.notMember key presentKeys] + absentLookups = + [(key, Patch.lookup key patch) | key <- absentKeys] + expectedAbsentLookups = + [(key, Nothing) | key <- absentKeys] + +patchRecordManyCoherence :: [(Int, CellPatch Int)] -> Property +patchRecordManyCoherence edits = + recordMany edits === recordAppliedFold edits + +recordAppliedFold :: [(Int, CellPatch Int)] -> Either (ComposeError Int Int) (Patch Int Int) +recordAppliedFold = + Foldable.foldl' appendApplied (Right empty) + where + appendApplied :: + Either (ComposeError Int Int) (Patch Int Int) -> + (Int, CellPatch Int) -> + Either (ComposeError Int Int) (Patch Int Int) + appendApplied applied (key, cell) = + applied >>= recordApplied key cell diff --git a/test/patch/Main.hs b/test/patch/Main.hs new file mode 100644 --- /dev/null +++ b/test/patch/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified PatchTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain PatchTests.tests diff --git a/test/patch/PatchLaws.hs b/test/patch/PatchLaws.hs new file mode 100644 --- /dev/null +++ b/test/patch/PatchLaws.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module PatchLaws + ( PatchChain (..), + PatchStaleCase (..), + patchLaws, + ) +where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import DeltaLaws (deltaNormalizeLaws) +import LawManifest + ( lawManifestCase, + lawProperty, + ) +import Moonlight.Core (IsLawName (..), constructorLawName) +import Moonlight.Delta.Patch +import Test.QuickCheck + ( Gen, + Property, + counterexample, + forAll, + (===), + ) +import Test.Tasty (TestTree, testGroup) + +data PatchChain key value = PatchChain + { pcKey :: !key, + pcOldValue :: !(Maybe value), + pcMiddleValue :: !(Maybe value), + pcNewValue :: !(Maybe value) + } + deriving stock (Eq, Show) + +data PatchStaleCase key value = PatchStaleCase + { pscKey :: !key, + pscExpectedValue :: !(Maybe value), + pscActualValue :: !(Maybe value), + pscReplacementValue :: !(Maybe value) + } + deriving stock (Eq, Show) + +data PatchLaw + = PatchCompatibleCompositionStitchesBoundary + | PatchCompositionApplicationSequential + | PatchStaleStateRejected + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance IsLawName PatchLaw where + lawNameText = + constructorLawName . show + +patchLaws :: + forall key value. + (PatchKey key, PatchValue value, Show key, Show value) => + String -> + Gen (Patch key value) -> + Gen (PatchChain key value) -> + Gen (PatchStaleCase key value) -> + TestTree +patchLaws label deltaGen chainGen staleGen = + testGroup + label + [ lawManifestCase label ([minBound .. maxBound] :: [PatchLaw]), + deltaNormalizeLaws "normalize" deltaGen, + lawProperty PatchCompatibleCompositionStitchesBoundary $ forAll chainGen patchComposition, + lawProperty PatchCompositionApplicationSequential $ forAll chainGen patchApplicationComposition, + lawProperty PatchStaleStateRejected $ forAll staleGen patchStaleRejection + ] + where + patchComposition :: PatchChain key value -> Property + patchComposition chain = + compose (patchChainNewer chain) (patchChainOlder chain) + === Right (patchChainComposed chain) + + patchApplicationComposition :: PatchChain key value -> Property + patchApplicationComposition chain = + case compose (patchChainNewer chain) (patchChainOlder chain) of + Right composed -> + apply composed (patchChainInitialState chain) + === ( apply (patchChainOlder chain) (patchChainInitialState chain) + >>= apply (patchChainNewer chain) + ) + Left err -> + counterexample ("compatible patch chain refused composition: " <> show err) False + + patchStaleRejection :: PatchStaleCase key value -> Property + patchStaleRejection staleCase = + apply + (singleton (pscKey staleCase) (cellFromEndpoints (pscExpectedValue staleCase) (pscReplacementValue staleCase))) + (patchState (pscKey staleCase) (pscActualValue staleCase)) + === Left + ApplyBeforeMismatch + { mismatchKey = pscKey staleCase, + expectedBefore = pscExpectedValue staleCase, + actualBefore = pscActualValue staleCase + } + +patchChainOlder :: PatchChain key value -> Patch key value +patchChainOlder chain = + singleton (pcKey chain) (cellFromEndpoints (pcOldValue chain) (pcMiddleValue chain)) + +patchChainNewer :: PatchChain key value -> Patch key value +patchChainNewer chain = + singleton (pcKey chain) (cellFromEndpoints (pcMiddleValue chain) (pcNewValue chain)) + +patchChainComposed :: PatchChain key value -> Patch key value +patchChainComposed chain = + singleton (pcKey chain) (cellFromEndpoints (pcOldValue chain) (pcNewValue chain)) + +patchChainInitialState :: Ord key => PatchChain key value -> Map key value +patchChainInitialState chain = + patchState (pcKey chain) (pcOldValue chain) + +patchState :: Ord key => key -> Maybe value -> Map key value +patchState key = + maybe Map.empty (Map.singleton key) diff --git a/test/patch/PatchSupport.hs b/test/patch/PatchSupport.hs new file mode 100644 --- /dev/null +++ b/test/patch/PatchSupport.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE DerivingStrategies #-} + +module PatchSupport where + +import Data.Map.Strict qualified as Map +import PatchLaws + ( PatchChain (..), + PatchStaleCase (..), + ) +import Moonlight.Delta.Patch +import Test.QuickCheck + ( Gen, + chooseInt, + elements, + frequency, + listOf, + sublistOf, + vectorOf, + ) + +data RepresentativeKey = RepresentativeKey + { representativeKeyOrder :: !Int, + representativeKeyName :: !String + } + deriving stock (Show) + +instance Eq RepresentativeKey where + left == right = + representativeKeyOrder left == representativeKeyOrder right + +instance Ord RepresentativeKey where + compare left right = + compare (representativeKeyOrder left) (representativeKeyOrder right) + +data PatchFacadeChain = PatchFacadeChain + { pfcState0 :: !(Map.Map Int Int), + pfcState1 :: !(Map.Map Int Int), + pfcState2 :: !(Map.Map Int Int), + pfcState3 :: !(Map.Map Int Int) + } + deriving stock (Eq, Show) +patchDeltaEntriesStrictlyAscending :: Patch Int String -> Bool +patchDeltaEntriesStrictlyAscending = + keysStrictlyAscending . fmap fst . patchToAscList + +patchCanonicalBefore :: Patch key value -> Map.Map key value +patchCanonicalBefore = + mapMaybeWithKey (const cellBefore) + +patchCanonicalAfter :: Patch key value -> Map.Map key value +patchCanonicalAfter = + mapMaybeWithKey (const cellAfter) + +singletonPatch :: key -> Maybe value -> Maybe value -> Patch key value +singletonPatch key before after = + singleton key (cellFromEndpoints before after) + +patchFromList :: (PatchKey key, PatchValue value) => [(key, CellPatch value)] -> Patch key value +patchFromList = + fromList + +patchToAscList :: Patch key value -> [(key, CellPatch value)] +patchToAscList = + toAscList + +keysStrictlyAscending :: [Int] -> Bool +keysStrictlyAscending keysList = + case keysList of + [] -> + True + [_key] -> + True + left : right : rest -> + left < right && keysStrictlyAscending (right : rest) + +patchCellValues :: [Maybe String] +patchCellValues = + [ Nothing, + Just "a", + Just "b", + Just "c" + ] + +patchCellValueGen :: Gen (Maybe String) +patchCellValueGen = + elements patchCellValues + +patchEntryGen :: Gen (Int, CellPatch String) +patchEntryGen = + (,) + <$> chooseInt (0, 16) + <*> (cellFromEndpoints <$> patchCellValueGen <*> patchCellValueGen) + +patchDeltaGen :: Gen (Patch Int String) +patchDeltaGen = + patchFromList <$> listOf patchEntryGen + +patchPairGen :: Gen (Patch Int String, Patch Int String) +patchPairGen = + (,) <$> patchDeltaGen <*> patchDeltaGen + +patchStateEntryGen :: Gen (Int, String) +patchStateEntryGen = + (,) <$> chooseInt (0, 16) <*> elements ["a", "b", "c"] + +patchStateGen :: Gen (Map.Map Int String) +patchStateGen = + Map.fromList <$> listOf patchStateEntryGen + +patchApplyCaseGen :: Gen (Map.Map Int String, Patch Int String) +patchApplyCaseGen = + (,) <$> patchStateGen <*> patchDeltaGen + +patchReplayCaseGen :: Gen (Map.Map Int String, [Patch Int String]) +patchReplayCaseGen = + (,) <$> patchStateGen <*> listOf patchDeltaGen + +patchThresholdStraddlingSizes :: [Int] +patchThresholdStraddlingSizes = + [0, 1, 8, 15, 16, 17, 32] + +patchStraddlingGen :: Gen (Patch Int String) +patchStraddlingGen = do + targetSize <- elements patchThresholdStraddlingSizes + cells <- vectorOf targetSize (snd <$> patchEntryGen) + pure (patchFromList (zip [0 ..] cells)) + +patchStraddlingApplyCaseGen :: Gen (Map.Map Int String, Patch Int String) +patchStraddlingApplyCaseGen = + (,) <$> patchStateGen <*> patchStraddlingGen + +patchStraddlingPairGen :: Gen (Patch Int String, Patch Int String) +patchStraddlingPairGen = + (,) <$> patchStraddlingGen <*> patchStraddlingGen + +patchStraddlingReplayCaseGen :: Gen (Map.Map Int String, [Patch Int String]) +patchStraddlingReplayCaseGen = + (,) <$> patchStateGen <*> listOf patchStraddlingGen + +patchStatePairGen :: Gen (Map.Map Int String, Map.Map Int String) +patchStatePairGen = + (,) <$> patchStateGen <*> patchStateGen + +patchFacadeChainGen :: Gen PatchFacadeChain +patchFacadeChainGen = + frequency + [ (1, elements (patchFacadeChain <$> patchFacadeKeyFamilies)), + (9, patchFacadeRandomChainGen) + ] + +patchFacadeRandomChainGen :: Gen PatchFacadeChain +patchFacadeRandomChainGen = + PatchFacadeChain + <$> patchFacadeRandomStateGen + <*> patchFacadeRandomStateGen + <*> patchFacadeRandomStateGen + <*> patchFacadeRandomStateGen + +patchFacadeKeyUniverse :: [Int] +patchFacadeKeyUniverse = + [0 .. 8] + +patchFacadeRandomStateGen :: Gen (Map.Map Int Int) +patchFacadeRandomStateGen = + sublistOf patchFacadeKeyUniverse + >>= fmap Map.fromList . traverse patchFacadeRandomStateEntryGen + +patchFacadeRandomStateEntryGen :: Int -> Gen (Int, Int) +patchFacadeRandomStateEntryGen key = + (,) key <$> chooseInt (0, 3) + +patchAppliedEditListGen :: Gen [(Int, CellPatch Int)] +patchAppliedEditListGen = + patchFacadeChainEdits <$> patchFacadeChainGen + +patchFacadeKeyFamilies :: [([Int], [Int], [Int], [Int])] +patchFacadeKeyFamilies = + [ ([0 .. 8], [0 .. 8], [0 .. 8], [0 .. 8]), + ([0, 2, 4, 6, 8], [1, 3, 5, 7], [0, 1, 2, 6, 7, 8], [0 .. 8]), + ([0 .. 4], [2 .. 6], [4 .. 8], [1, 3, 5, 7]), + ([0, 1], [3, 4], [6, 7], [2, 5, 8]), + ([0, 4, 8], [0, 1, 4, 7], [2, 4, 6, 8], [1, 2, 3, 5, 8]) + ] + +patchFacadeChain :: ([Int], [Int], [Int], [Int]) -> PatchFacadeChain +patchFacadeChain (keys0, keys1, keys2, keys3) = + PatchFacadeChain + { pfcState0 = patchFacadeState 0 keys0, + pfcState1 = patchFacadeState 1 keys1, + pfcState2 = patchFacadeState 2 keys2, + pfcState3 = patchFacadeState 3 keys3 + } + +patchFacadeState :: Int -> [Int] -> Map.Map Int Int +patchFacadeState stage keys = + Map.fromAscList + [ (key, stage * 16 + key) + | key <- keys + ] + +patchFacadeChainEdits :: PatchFacadeChain -> [(Int, CellPatch Int)] +patchFacadeChainEdits chain = + toAscList (diff (pfcState0 chain) (pfcState1 chain)) + <> toAscList (diff (pfcState1 chain) (pfcState2 chain)) + <> toAscList (diff (pfcState2 chain) (pfcState3 chain)) + +patchChainGen :: Gen (PatchChain Int String) +patchChainGen = + PatchChain + <$> chooseInt (0, 16) + <*> patchCellValueGen + <*> patchCellValueGen + <*> patchCellValueGen + +patchStaleCaseGen :: Gen (PatchStaleCase Int String) +patchStaleCaseGen = do + key <- chooseInt (0, 16) + expected <- patchCellValueGen + actual <- elements (filter (/= expected) patchCellValues) + replacement <- patchCellValueGen + pure + PatchStaleCase + { pscKey = key, + pscExpectedValue = expected, + pscActualValue = actual, + pscReplacementValue = replacement + } diff --git a/test/patch/PatchTests.hs b/test/patch/PatchTests.hs new file mode 100644 --- /dev/null +++ b/test/patch/PatchTests.hs @@ -0,0 +1,26 @@ +module PatchTests + ( patchDeltaGen, + tests, + ) +where + +import CodecSpec (codecTests) +import LawsSpec (lawTests) +import ReferenceSpec (referenceTests) +import ReplaySpec (replayTests) +import SemanticsSpec (semanticTests) +import DeltaHashSpec (deltaHashTests) +import PatchSupport (patchDeltaGen) +import Test.Tasty (TestTree, testGroup) + +tests :: TestTree +tests = + testGroup + "patch" + [ lawTests, + semanticTests, + codecTests, + replayTests, + referenceTests, + deltaHashTests + ] diff --git a/test/patch/ReferenceSpec.hs b/test/patch/ReferenceSpec.hs new file mode 100644 --- /dev/null +++ b/test/patch/ReferenceSpec.hs @@ -0,0 +1,166 @@ +module ReferenceSpec + ( referenceTests, + ) +where + +import Data.Map.Internal.Debug qualified as MapDebug +import Data.Map.Strict qualified as Map +import Moonlight.Delta.Patch +import PatchSupport +import PatchReference qualified +import Test.QuickCheck + ( Property, + forAll, + (===), + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) +import Test.Tasty.QuickCheck (testProperty) + +referenceTests :: TestTree +referenceTests = + testGroup + "reference" + [ testProperty "compose matches reference" $ forAll patchPairGen patchComposeMatchesReference, + testProperty "compose emits strictly ascending patch entries" $ + forAll patchPairGen patchComposeEmitsStrictlyAscendingEntries, + testProperty "apply matches reference" $ forAll patchApplyCaseGen patchApplyMatchesReference, + testProperty "apply emits a valid map" $ forAll patchApplyCaseGen patchApplyEmitsValidMap, + testProperty "fused replay matches sequential reference" $ forAll patchReplayCaseGen patchReplayMatchesReference, + testProperty "fused replay emits a valid map" $ forAll patchReplayCaseGen patchReplayEmitsValidMap, + testProperty "diff applies from source to target" $ forAll patchStatePairGen patchDiffApplies, + testProperty "invert reverses canonical endpoints" $ forAll patchDeltaGen patchInvertReversesCanonicalEndpoints, + testProperty "invert is involutive" $ forAll patchDeltaGen patchInvertInvolutive, + testProperty "authoritative map construction round-trips the logical view" $ + forAll patchDeltaGen patchMapRoundTrip, + testGroup + "small-form threshold sweep" + [ testProperty "apply matches reference across the small/paged threshold" $ + forAll patchStraddlingApplyCaseGen patchApplyMatchesReference, + testProperty "compose matches reference across the small/paged threshold" $ + forAll patchStraddlingPairGen patchComposeMatchesReference, + testProperty "fused replay matches reference across the small/paged threshold" $ + forAll patchStraddlingReplayCaseGen patchReplayMatchesReference, + testProperty "map construction round-trips across the small/paged threshold" $ + forAll patchStraddlingGen patchMapRoundTrip, + testProperty "invert is involutive across the small/paged threshold" $ + forAll patchStraddlingGen patchInvertInvolutive + ], + testCase "all finite two-key compositions match the reference" $ + finiteCompositionMismatches @?= [], + testCase "all finite two-key applications match the reference" $ + finiteApplicationMismatches @?= [], + testCase "all finite two-step replays match the reference" $ + finiteReplayMismatches @?= [] + ] + +patchComposeMatchesReference :: (Patch Int String, Patch Int String) -> Property +patchComposeMatchesReference (newer, older) = + compose newer older + === PatchReference.compose newer older + +patchComposeEmitsStrictlyAscendingEntries :: (Patch Int String, Patch Int String) -> Property +patchComposeEmitsStrictlyAscendingEntries (newer, older) = + case compose newer older of + Left _err -> + True === True + Right patch -> + patchDeltaEntriesStrictlyAscending patch === True + +patchApplyMatchesReference :: (Map.Map Int String, Patch Int String) -> Property +patchApplyMatchesReference (state, patch) = + apply patch state + === PatchReference.apply patch state + +patchApplyEmitsValidMap :: (Map.Map Int String, Patch Int String) -> Property +patchApplyEmitsValidMap (state, patch) = + case apply patch state of + Left _err -> + True === True + Right result -> + MapDebug.valid result === True + +patchReplayMatchesReference :: (Map.Map Int String, [Patch Int String]) -> Property +patchReplayMatchesReference (state, patches) = + replay patches state + === PatchReference.replay patches state + +patchReplayEmitsValidMap :: (Map.Map Int String, [Patch Int String]) -> Property +patchReplayEmitsValidMap (state, patches) = + case replay patches state of + Left _err -> + True === True + Right result -> + MapDebug.valid result === True + +patchDiffApplies :: (Map.Map Int String, Map.Map Int String) -> Property +patchDiffApplies (before, after) = + apply (diff before after) before === Right after + +patchInvertReversesCanonicalEndpoints :: Patch Int String -> Property +patchInvertReversesCanonicalEndpoints patch = + apply (invert patch) (patchCanonicalAfter patch) === Right (patchCanonicalBefore patch) + +patchInvertInvolutive :: Patch Int String -> Property +patchInvertInvolutive patch = + invert (invert patch) === patch + +patchMapRoundTrip :: Patch Int String -> Property +patchMapRoundTrip patch = + fromAscList (toAscList patch) === patch +finiteCompositionMismatches :: [((Patch Int Bool, Patch Int Bool), Either (ComposeError Int Bool) (Patch Int Bool), Either (ComposeError Int Bool) (Patch Int Bool))] +finiteCompositionMismatches = + take + 1 + [ ((newer, older), actual, expected) + | newer <- finitePatches, + older <- finitePatches, + let actual = compose newer older, + let expected = PatchReference.compose newer older, + actual /= expected + ] + +finiteApplicationMismatches :: [((Map.Map Int Bool, Patch Int Bool), Either (ApplyError Int Bool) (Map.Map Int Bool), Either (ApplyError Int Bool) (Map.Map Int Bool))] +finiteApplicationMismatches = + take + 1 + [ ((state, patch), actual, expected) + | state <- finiteStates, + patch <- finitePatches, + let actual = apply patch state, + let expected = PatchReference.apply patch state, + actual /= expected + ] + +finiteReplayMismatches :: [((Map.Map Int Bool, Patch Int Bool, Patch Int Bool), Either (ReplayError Int Bool) (Map.Map Int Bool), Either (ReplayError Int Bool) (Map.Map Int Bool))] +finiteReplayMismatches = + take + 1 + [ ((state, first, second), actual, expected) + | state <- finiteStates, + first <- finitePatches, + second <- finitePatches, + let patches = [first, second], + let actual = replay patches state, + let expected = PatchReference.replay patches state, + actual /= expected + ] + +finitePatches :: [Patch Int Bool] +finitePatches = + [ fromAscList [(key, cell) | (key, Just cell) <- zip [0, 1] choices] + | choices <- sequence (replicate 2 (Nothing : fmap Just finiteCells)) + ] + +finiteCells :: [CellPatch Bool] +finiteCells = + [ cellFromEndpoints before after + | before <- [Nothing, Just False, Just True], + after <- [Nothing, Just False, Just True] + ] + +finiteStates :: [Map.Map Int Bool] +finiteStates = + [ Map.fromAscList [(key, value) | (key, Just value) <- zip [0, 1] choices] + | choices <- sequence (replicate 2 [Nothing, Just False, Just True]) + ] diff --git a/test/patch/ReplaySpec.hs b/test/patch/ReplaySpec.hs new file mode 100644 --- /dev/null +++ b/test/patch/ReplaySpec.hs @@ -0,0 +1,162 @@ +module ReplaySpec + ( replayTests, + ) +where + +import Data.Map.Strict qualified as Map +import Moonlight.Delta.Patch +import PatchSupport +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), assertFailure, testCase) + +replayTests :: TestTree +replayTests = + testGroup + "replay" + [ testCase "fused replay uses the latest patch representative across aligned support" $ + let firstPatchKey = + RepresentativeKey 1 "first-patch" + secondPatchKey = + RepresentativeKey 1 "second-patch" + stateKey = + RepresentativeKey 1 "state" + patches = + [ singletonPatch firstPatchKey (Just "old") (Just "middle"), + singletonPatch secondPatchKey (Just "middle") (Just "new") + ] + in fmap (fmap (representativeKeyName . fst) . Map.toAscList) (replay patches (Map.singleton stateKey "old")) + @?= Right ["second-patch"], + testCase "aligned replay retains first-before and latest-after endpoints" alignedReplayCase, + testCase "fused replay boundary mismatch reports the next patch representative" $ + let firstPatchKey = + RepresentativeKey 1 "first-patch" + secondPatchKey = + RepresentativeKey 1 "second-patch" + stateKey = + RepresentativeKey 1 "state" + patches = + [ singletonPatch firstPatchKey (Just "old") (Just "middle"), + singletonPatch secondPatchKey (Just "wrong") (Just "new") + ] + in case replay patches (Map.singleton stateKey "old") of + Left replayError -> do + replayIndex replayError @?= 1 + representativeKeyName (mismatchKey (replayApply replayError)) @?= "second-patch" + expectedBefore (replayApply replayError) @?= Just "wrong" + actualBefore (replayApply replayError) @?= Just "middle" + Right _ -> + assertFailure "expected replay boundary mismatch", + testCase "divergent singleton replay finalizes ascending disjoint keys" $ + let initialState = + Map.fromAscList [(0 :: Int, 0 :: Int), (1, 10), (2, 20), (3, 30)] + patchForKey :: Int -> Patch Int Int + patchForKey key = + singletonPatch key (Just (key * 10)) (Just (key * 10 + 1)) + expectedState = + Map.fromAscList [(0, 1), (1, 11), (2, 21), (3, 31)] + in replay (fmap patchForKey [0 .. 3]) initialState + @?= Right expectedState, + testCase "divergent singleton replay batches repeated keys" $ + let initialState = + Map.fromAscList [(0 :: Int, 0 :: Int), (1, 0)] + patches = + [ singletonPatch 0 (Just 0) (Just 1), + singletonPatch 1 (Just 0) (Just 1), + singletonPatch 0 (Just 1) (Just 2), + singletonPatch 1 (Just 1) (Just 2) + ] + in replay patches initialState + @?= Right (Map.fromAscList [(0, 2), (1, 2)]), + testCase "divergent singleton replay keeps latest patch representatives" $ + let firstPatchKey = + RepresentativeKey 1 "first-patch" + latestPatchKey = + RepresentativeKey 1 "latest-patch" + supportPatchKey = + RepresentativeKey 2 "support-patch" + stateKey = + RepresentativeKey 1 "state" + supportStateKey = + RepresentativeKey 2 "support-state" + patches = + [ singletonPatch firstPatchKey (Just "old") (Just "middle"), + singletonPatch supportPatchKey (Just "zero") (Just "one"), + singletonPatch latestPatchKey (Just "middle") (Just "new") + ] + initialState = + Map.fromAscList + [ (stateKey, "old"), + (supportStateKey, "zero") + ] + in fmap (fmap (representativeKeyName . fst) . Map.toAscList) (replay patches initialState) + @?= Right ["latest-patch", "support-patch"], + testCase "divergent singleton replay reports the stale patch index" $ + let stalePatchKey = + RepresentativeKey 1 "stale-patch" + stateKey = + RepresentativeKey 1 "state" + patches = + [ singletonPatch (RepresentativeKey 1 "first-patch") (Just "old") (Just "middle"), + singletonPatch (RepresentativeKey 2 "support-patch") (Just "zero") (Just "one"), + singletonPatch stalePatchKey (Just "wrong") (Just "new") + ] + initialState = + Map.fromAscList + [ (stateKey, "old"), + (RepresentativeKey 2 "support-state", "zero") + ] + in case replay patches initialState of + Left replayError -> do + replayIndex replayError @?= 2 + representativeKeyName (mismatchKey (replayApply replayError)) @?= "stale-patch" + expectedBefore (replayApply replayError) @?= Just "wrong" + actualBefore (replayApply replayError) @?= Just "middle" + Right _ -> + assertFailure "expected stale replay failure", + testCase "divergent singleton replay checks assert-absent before insert" $ + let patches = + [ singletonPatch (0 :: Int) Nothing Nothing, + singletonPatch 1 Nothing Nothing, + singletonPatch 0 Nothing (Just "inserted") + ] + in replay patches Map.empty + @?= Right (Map.singleton 0 "inserted"), + testCase "divergent singleton replay falls back at the current patch" $ + let initialState = + Map.fromAscList [(0 :: Int, 0 :: Int), (1, 0)] + patches = + [ singletonPatch 0 (Just 0) (Just 1), + singletonPatch 1 (Just 0) (Just 1), + fromAscList + [ (0, replace 1 2), + (1, replace 1 2) + ] + ] + in replay patches initialState + @?= Right (Map.fromAscList [(0, 2), (1, 2)]) + ] + +alignedReplayCase :: IO () +alignedReplayCase = do + let supportKeys :: [Int] + supportKeys = [0 .. 127] + stepCount :: Int + stepCount = 96 + initialState = + Map.fromAscList + [ (key, 0) + | key <- supportKeys + ] + patchAt :: Int -> Patch Int Int + patchAt step = + fromAscList + [ (key, replace step (step + 1)) + | key <- supportKeys + ] + patches = fmap patchAt [0 .. stepCount - 1] + expectedState = + Map.fromAscList + [ (key, stepCount) + | key <- supportKeys + ] + replay patches initialState @?= Right expectedState diff --git a/test/patch/SemanticsSpec.hs b/test/patch/SemanticsSpec.hs new file mode 100644 --- /dev/null +++ b/test/patch/SemanticsSpec.hs @@ -0,0 +1,285 @@ +module SemanticsSpec + ( semanticTests, + ) +where + +import Data.Map.Strict qualified as Map +import Moonlight.Delta.Patch +import Moonlight.Delta.Patch qualified as Patch +import PatchSupport +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), assertFailure, testCase) + +semanticTests :: TestTree +semanticTests = + testGroup + "semantics" + [ testCase "composition rejects incompatible cell boundary" $ + compose + (singletonPatch (1 :: Int) (Just "x") (Just "b")) + (singletonPatch (1 :: Int) Nothing (Just "a")) + @?= + Left + ComposeBoundaryMismatch + { boundaryKey = 1, + olderAfter = Just "a", + newerBefore = Just "x" + }, + testCase "normalization preserves assertion-only cells" $ + let assertion = + singletonPatch (1 :: Int) (Just "a") (Just "a") + in do + Patch.null (normalize assertion) @?= False + apply + (normalize assertion) + (Map.singleton 1 "b") + @?= + Left + ApplyBeforeMismatch + { mismatchKey = 1, + expectedBefore = Just "a", + actualBefore = Just "b" + }, + testCase "composition preserves round-trip source assertion" $ + let older = + singletonPatch (1 :: Int) (Just "a") (Just "b") + newer = + singletonPatch 1 (Just "b") (Just "a") + assertion = + singletonPatch 1 (Just "a") (Just "a") + in do + compose newer older @?= Right assertion + apply assertion (Map.singleton 1 "c") + @?= + Left + ApplyBeforeMismatch + { mismatchKey = 1, + expectedBefore = Just "a", + actualBefore = Just "c" + }, + testCase "applied cell recording keeps endpoints only" $ + let applied = + recordApplied + 1 + (cellFromEndpoints (Just "a") (Just "b")) + empty + >>= recordApplied + (1 :: Int) + (cellFromEndpoints (Just "b") (Just "c")) + in applied @?= Right (singletonPatch 1 (Just "a") (Just "c")), + testCase "applied round trip remains a checked assertion" $ + let applied = + recordApplied + 1 + (cellFromEndpoints (Just "a") (Just "b")) + empty + >>= recordApplied + (1 :: Int) + (cellFromEndpoints (Just "b") (Just "a")) + assertion = + singletonPatch 1 (Just "a") (Just "a") + in do + applied @?= Right assertion + case applied of + Left err -> + assertFailure (show err) + Right patch -> + apply patch (Map.singleton 1 "stale") + @?= + Left + ApplyBeforeMismatch + { mismatchKey = 1, + expectedBefore = Just "a", + actualBefore = Just "stale" + }, + testCase "applied cell recording rejects discontinuous producer boundary" $ + let applied = + recordApplied + 1 + (cellFromEndpoints (Just "a") (Just "b")) + empty + >>= recordApplied + (1 :: Int) + (cellFromEndpoints (Just "c") (Just "d")) + in applied + @?= + Left + ComposeBoundaryMismatch + { boundaryKey = 1, + olderAfter = Just "b", + newerBefore = Just "c" + }, + testCase "recordMany interprets repeated keys temporally" $ + recordMany + [ (1 :: Int, replace "a" "b"), + (1, replace "b" "c") + ] + @?= Right (singleton 1 (replace "a" "c")), + testCase "fromAscList falls back to canonical construction for nonascending input" $ + fromAscList + [ (2 :: Int, insert "b"), + (1, insert "a"), + (2, replace "b" "c") + ] + @?= fromList + [ (2, insert "b"), + (1, insert "a"), + (2, replace "b" "c") + ], + testCase "absence assertion is a restricted identity" $ do + let assertion = singleton (1 :: Int) (assertAbsent :: CellPatch String) + Patch.null assertion @?= False + apply assertion Map.empty @?= Right (Map.empty :: Map.Map Int String) + apply assertion (Map.singleton 1 "present") + @?= + Left + ApplyBeforeMismatch + { mismatchKey = 1, + expectedBefore = Nothing, + actualBefore = Just "present" + }, + testCase "apply mismatch reports the patch key representative" $ + let patchKey = + RepresentativeKey 1 "patch" + stateKey = + RepresentativeKey 1 "state" + patch = + singletonPatch patchKey (Just "expected") (Just "new") + in case apply patch (Map.singleton stateKey "actual") of + Left mismatch -> do + representativeKeyName (mismatchKey mismatch) @?= "patch" + expectedBefore mismatch @?= Just "expected" + actualBefore mismatch @?= Just "actual" + Right _ -> + assertFailure "expected representative-key mismatch", + testCase "apply update uses the patch key representative" $ + let patchKey = + RepresentativeKey 1 "patch" + stateKey = + RepresentativeKey 1 "state" + patch = + singletonPatch patchKey (Just "old") (Just "new") + in fmap (fmap (representativeKeyName . fst) . Map.toAscList) (apply patch (Map.singleton stateKey "old")) + @?= Right ["patch"], + testCase "dense apply uses patch representatives for every matched key" $ + let rowKeys :: [Int] + rowKeys = [0 .. 127] + state = + Map.fromAscList + [ (RepresentativeKey key "state", key) + | key <- rowKeys + ] + patch = + fromAscList + [ (RepresentativeKey key "patch", replace key (key + 1)) + | key <- rowKeys + ] + labels :: Map.Map RepresentativeKey Int -> [String] + labels = + fmap (representativeKeyName . fst) . Map.toAscList + in fmap labels (apply patch state) + @?= Right (replicate 128 "patch"), + testCase "composition is independent of page layout" differentPageLayoutCase, + testCase "mask-first validation preserves least-key error ordering" maskFirstLeastMismatchCase, + testCase "disjoint composition preserves logical rows across an underfull seam" disjointSeamCase, + testCase "endpoint-native fold agrees with logical row materialization" endpointNativeFoldCase + ] + +maskFirstLeastMismatchCase :: IO () +maskFirstLeastMismatchCase = do + let older :: Patch Int Int + older = + fromAscList + [ (0, replace 0 10), + (1, insert 20) + ] + newer :: Patch Int Int + newer = + fromAscList + [ (0, replace 11 12), + (1, assertAbsent) + ] + compose newer older + @?= Left + ComposeBoundaryMismatch + { boundaryKey = 0, + olderAfter = Just 10, + newerBefore = Just 11 + } + +disjointSeamCase :: IO () +disjointSeamCase = do + let olderRows :: [(Int, CellPatch Int)] + olderRows = + [ (key, replace key (key + 1)) + | key <- [0 .. 30] + ] + newerRows :: [(Int, CellPatch Int)] + newerRows = + [ (key, replace key (key + 1)) + | key <- [100 .. 130] + ] + older = fromAscList olderRows + newer = fromAscList newerRows + expected = fromAscList (olderRows <> newerRows) + compose newer older @?= Right expected + +endpointNativeFoldCase :: IO () +endpointNativeFoldCase = do + let patch :: Patch Int Int + patch = + fromAscList + [ (0, assertAbsent), + (1, insert 10), + (2, delete 20), + (3, replace 30 31) + ] + folded = + foldWithKey' + (\ !total key -> total + key) + (\ !total key after -> total + key + after) + (\ !total key before -> total + key + before) + (\ !total key before after -> total + key + before + after) + 0 + patch + materialized = + foldl' + ( \ !total (key, cell) -> + total + + key + + maybe 0 id (cellBefore cell) + + maybe 0 id (cellAfter cell) + ) + 0 + (toAscList patch) + folded @?= materialized + +differentPageLayoutCase :: IO () +differentPageLayoutCase = do + let rowKeys :: [Int] + rowKeys = [0 .. 256] + olderRows = + [ (key, replace key (key + 1)) + | key <- rowKeys + ] + newerRows = + [ (key, replace (key + 1) (key + 2)) + | key <- rowKeys + ] + expectedRows = + [ (key, replace key (key + 2)) + | key <- rowKeys + ] + initialState = Map.fromAscList [(key, key) | key <- rowKeys] + finalState = Map.fromAscList [(key, key + 2) | key <- rowKeys] + olderCanonical = fromAscList olderRows + newerCanonical = fromAscList newerRows + expected = fromAscList expectedRows + case recordMany (reverse olderRows) of + Left err -> + assertFailure ("unexpected recordMany rejection: " <> show err) + Right olderRecorded -> do + olderRecorded @?= olderCanonical + compare olderRecorded olderCanonical @?= EQ + compose newerCanonical olderRecorded @?= Right expected + replay [olderRecorded, newerCanonical] initialState @?= Right finalState diff --git a/test/repair/Main.hs b/test/repair/Main.hs new file mode 100644 --- /dev/null +++ b/test/repair/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified RepairTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain RepairTests.tests diff --git a/test/repair/RepairTests.hs b/test/repair/RepairTests.hs new file mode 100644 --- /dev/null +++ b/test/repair/RepairTests.hs @@ -0,0 +1,203 @@ +module RepairTests + ( tests, + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Moonlight.Delta.Repair +import Numeric.Natural (Natural) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) + +data RepairObstruction + = BelowTarget Int + | CannotRepair + deriving stock (Eq, Show) + +data RepairCorrectionValue + = Increment + | Noop + deriving stock (Eq, Show) + +tests :: TestTree +tests = + testGroup + "repair" + [ convergenceTest, + noProgressBudgetTest, + budgetExhaustionTest, + irreducibleTraceTest, + foldTraceOrderingTest, + focusRepairPreservesObstructedFocusStateTest, + productRepairPreservesInspectedStateTest, + sequenceRepairShortCircuitsLeftBeforeRightTest, + sequenceRepairRunsRightAfterLeftConvergesTest, + productRepairAccumulatesBothObstructionsInOrderTest + ] + +convergenceTest :: TestTree +convergenceTest = + testCase "bounded repair converges" $ + boundedRepair (incrementKernel 2) (Config 4) 0 + @?= ResultConverged 2 2 + +noProgressBudgetTest :: TestTree +noProgressBudgetTest = + testCase "no-op corrections exhaust budget instead of trusting a stable hash" $ + boundedRepair noProgressKernel (Config 2) 0 + @?= ResultBudgetExhausted 0 (BelowTarget 1 :| []) 2 + +budgetExhaustionTest :: TestTree +budgetExhaustionTest = + testCase "repair reports budget exhaustion with current obstruction" $ + boundedRepair (incrementKernel 3) (Config 1) 0 + @?= ResultBudgetExhausted 1 (BelowTarget 3 :| []) 1 + +irreducibleTraceTest :: TestTree +irreducibleTraceTest = + testCase "irreducible obstruction is traced as typed correction" $ do + let (result, traceValue) = boundedRepairTraced irreducibleKernel (Config 4) 0 + result @?= ResultStuck 0 (CannotRepair :| []) 0 + traceProjection traceValue + @?= [(CannotRepair :| [], Irreducible CannotRepair :| [], 0, [CannotRepair])] + +foldTraceOrderingTest :: TestTree +foldTraceOrderingTest = + testCase "trace preserves fold order" $ + traceProjection (snd (boundedRepairTraced (incrementKernel 2) (Config 4) 0)) + @?= + [ (BelowTarget 2 :| [], Applied (BelowTarget 2) Increment :| [], 1, []), + (BelowTarget 2 :| [], Applied (BelowTarget 2) Increment :| [], 1, []) + ] + +focusRepairPreservesObstructedFocusStateTest :: TestTree +focusRepairPreservesObstructedFocusStateTest = + testCase "focusRepair embeds obstructed inner state" $ + check (focusRepair snd replaceFocus focusNormalizingKernel) ("outer", 0 :: Int) + @?= StepObstructed ("outer", 1) (BelowTarget 1 :| []) + +productRepairPreservesInspectedStateTest :: TestTree +productRepairPreservesInspectedStateTest = + testCase "productRepair preserves inspection state instead of returning the original" $ + check (productRepair normalizingConvergedKernel normalizingObstructedKernel) (0 :: Int) + @?= StepObstructed 11 (Right (BelowTarget 11) :| []) + +sequenceRepairShortCircuitsLeftBeforeRightTest :: TestTree +sequenceRepairShortCircuitsLeftBeforeRightTest = + testCase "SequenceRepairShortCircuitsLeftBeforeRight" $ do + let (result, traceValue) = + boundedRepairTraced + (sequenceRepair leftObstructedIncrementKernel rightKernelMustNotRun) + (Config 1) + (0 :: Int) + result @?= ResultBudgetExhausted 1 (Left (BelowTarget 3) :| []) 1 + traceProjection traceValue + @?= [(Left (BelowTarget 3) :| [], Applied (Left (BelowTarget 3)) (Left Increment) :| [], 1, [])] + +sequenceRepairRunsRightAfterLeftConvergesTest :: TestTree +sequenceRepairRunsRightAfterLeftConvergesTest = + testCase "SequenceRepairRunsRightAfterLeftConverges" $ + check + (sequenceRepair normalizingConvergedKernel normalizingObstructedKernel) + (0 :: Int) + @?= StepObstructed 11 (Right (BelowTarget 11) :| []) + +productRepairAccumulatesBothObstructionsInOrderTest :: TestTree +productRepairAccumulatesBothObstructionsInOrderTest = + testCase "ProductRepairAccumulatesBothObstructionsInOrder" $ + check + (productRepair normalizingObstructedKernel normalizingObstructedKernel) + (0 :: Int) + @?= StepObstructed 20 (Left (BelowTarget 10) :| [Right (BelowTarget 20)]) + +incrementKernel :: Int -> Kernel Int RepairObstruction RepairCorrectionValue +incrementKernel target = + Kernel + { check = \state -> + if state >= target + then StepConverged state + else StepObstructed state (BelowTarget target :| []), + residuate = \obstruction -> + case obstruction of + BelowTarget _ -> Just Increment + CannotRepair -> Nothing, + applyKernelCorrection = \state correction -> + case correction of + Increment -> state + 1 + Noop -> state + } + +noProgressKernel :: Kernel Int RepairObstruction RepairCorrectionValue +noProgressKernel = + Kernel + { check = \state -> StepObstructed state (BelowTarget 1 :| []), + residuate = const (Just Noop), + applyKernelCorrection = \state correction -> + case correction of + Increment -> state + 1 + Noop -> state + } + +irreducibleKernel :: Kernel Int RepairObstruction RepairCorrectionValue +irreducibleKernel = + Kernel + { check = \state -> StepObstructed state (CannotRepair :| []), + residuate = const Nothing, + applyKernelCorrection = \state _ -> state + } + +replaceFocus :: (outer, focus) -> focus -> (outer, focus) +replaceFocus (outer, _) focus = + (outer, focus) + +focusNormalizingKernel :: Kernel Int RepairObstruction RepairCorrectionValue +focusNormalizingKernel = + Kernel + { check = \focus -> StepObstructed (focus + 1) (BelowTarget 1 :| []), + residuate = const Nothing, + applyKernelCorrection = \focus _ -> focus + } + +normalizingConvergedKernel :: Kernel Int RepairObstruction RepairCorrectionValue +normalizingConvergedKernel = + Kernel + { check = \state -> StepConverged (state + 1), + residuate = const Nothing, + applyKernelCorrection = \state _ -> state + } + +normalizingObstructedKernel :: Kernel Int RepairObstruction RepairCorrectionValue +normalizingObstructedKernel = + Kernel + { check = \state -> StepObstructed (state + 10) (BelowTarget (state + 10) :| []), + residuate = const Nothing, + applyKernelCorrection = \state _ -> state + } + +leftObstructedIncrementKernel :: Kernel Int RepairObstruction RepairCorrectionValue +leftObstructedIncrementKernel = + Kernel + { check = \state -> StepObstructed state (BelowTarget 3 :| []), + residuate = \obstruction -> + case obstruction of + BelowTarget _ -> Just Increment + CannotRepair -> Nothing, + applyKernelCorrection = \state correction -> + case correction of + Increment -> state + 1 + Noop -> state + } + +rightKernelMustNotRun :: Kernel Int RepairObstruction RepairCorrectionValue +rightKernelMustNotRun = + Kernel + { check = \state -> StepObstructed state (CannotRepair :| []), + residuate = const Nothing, + applyKernelCorrection = \state _ -> state + } + +traceProjection :: + Trace obstruction correction -> + [(NonEmpty obstruction, NonEmpty (Correction obstruction correction), Natural, [obstruction])] +traceProjection = + fmap (\roundValue -> (obstructions roundValue, corrections roundValue, applied roundValue, irreducible roundValue)) . rounds