packages feed

moonlight-delta (empty) → 0.1.0.0

raw patch · 87 files changed

+16634/−0 lines, 87 filesdep +QuickCheckdep +basedep +containers

Dependencies added: QuickCheck, base, containers, deepseq, moonlight-algebra, moonlight-core, moonlight-delta, primitive, tasty, tasty-bench, tasty-hunit, tasty-quickcheck, vector

Files

+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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`.
+ bench/aggregate/Main.hs view
@@ -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+    ]
+ bench/core/CoreBench.hs view
@@ -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
+ bench/core/Main.hs view
@@ -0,0 +1,13 @@+module Main+  ( main,+  )+where++import CoreBench+  ( coreBenchmarks,+  )+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [coreBenchmarks]
+ bench/epoch/EpochBench.hs view
@@ -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
+ bench/epoch/Main.hs view
@@ -0,0 +1,13 @@+module Main+  ( main,+  )+where++import EpochBench+  ( epochBenchmarks,+  )+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [epochBenchmarks]
+ bench/patch/Main.hs view
@@ -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]
+ bench/patch/Patch/Allocation.hs view
@@ -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
+ bench/patch/Patch/Fixtures.hs view
@@ -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
+ bench/patch/Patch/Hackage.hs view
@@ -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
+ bench/patch/Patch/Types.hs view
@@ -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"
+ bench/patch/PatchBench.hs view
@@ -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"
+ bench/repair/Main.hs view
@@ -0,0 +1,13 @@+module Main+  ( main,+  )+where++import RepairBench+  ( repairBenchmarks,+  )+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [repairBenchmarks]
+ bench/repair/RepairBench.hs view
@@ -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)
+ bench/support/BenchSupport.hs view
@@ -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
+ moonlight-delta.cabal view
@@ -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
+ src-core/Moonlight/Delta/Frontier.hs view
@@ -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)
+ src-core/Moonlight/Delta/Monotone.hs view
@@ -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)
+ src-core/Moonlight/Delta/Normalize.hs view
@@ -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
+ src-core/Moonlight/Delta/Operator.hs view
@@ -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)}
+ src-core/Moonlight/Delta/Scope.hs view
@@ -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 #-}
+ src-core/Moonlight/Delta/Signed.hs view
@@ -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
+ src-core/Moonlight/Delta/Support.hs view
@@ -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
+ src-core/Moonlight/Delta/Time.hs view
@@ -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}
+ src-epoch/Moonlight/Delta/Epoch.hs view
@@ -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,+  )
+ src-epoch/Moonlight/Delta/Epoch/Internal/Compose.hs view
@@ -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)
+ src-epoch/Moonlight/Delta/Epoch/Internal/Construction.hs view
@@ -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+    }
+ src-epoch/Moonlight/Delta/Epoch/Internal/Projection.hs view
@@ -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
+ src-epoch/Moonlight/Delta/Epoch/Internal/Transport.hs view
@@ -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 #-}
+ src-epoch/Moonlight/Delta/Epoch/Internal/Types.hs view
@@ -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
+ src-epoch/Moonlight/Delta/Epoch/Internal/Version.hs view
@@ -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
+ src-epoch/Moonlight/Delta/Epoch/Internal/View.hs view
@@ -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
+ src-patch-public/Moonlight/Delta/Patch.hs view
@@ -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,+  )
+ src-patch/Moonlight/Delta/Patch/Internal/Apply.hs view
@@ -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 #-}
+ src-patch/Moonlight/Delta/Patch/Internal/Builder.hs view
@@ -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 #-}
+ src-patch/Moonlight/Delta/Patch/Internal/Cell.hs view
@@ -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 #-}
+ src-patch/Moonlight/Delta/Patch/Internal/Compose/Aligned.hs view
@@ -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 #-}
+ src-patch/Moonlight/Delta/Patch/Internal/Compose/Core.hs view
@@ -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 #-}
+ src-patch/Moonlight/Delta/Patch/Internal/Compose/Range.hs view
@@ -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 #-}
+ src-patch/Moonlight/Delta/Patch/Internal/Compose/Record.hs view
@@ -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 #-}
+ src-patch/Moonlight/Delta/Patch/Internal/Compose/SameSupport.hs view
@@ -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 #-}+
+ src-patch/Moonlight/Delta/Patch/Internal/Construction.hs view
@@ -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 #-}
+ src-patch/Moonlight/Delta/Patch/Internal/Cursor.hs view
@@ -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 #-}
+ src-patch/Moonlight/Delta/Patch/Internal/IncrementalDigest.hs view
@@ -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
+ src-patch/Moonlight/Delta/Patch/Internal/MerkleDeltaHash.hs view
@@ -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
+ src-patch/Moonlight/Delta/Patch/Internal/MultisetDeltaHash.hs view
@@ -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
+ src-patch/Moonlight/Delta/Patch/Internal/NodeCommitment.hs view
@@ -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
+ src-patch/Moonlight/Delta/Patch/Internal/Page.hs view
@@ -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 #-}
+ src-patch/Moonlight/Delta/Patch/Internal/Replay.hs view
@@ -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 #-}
+ src-patch/Moonlight/Delta/Patch/Internal/Types.hs view
@@ -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
+ src-repair/Moonlight/Delta/Repair.hs view
@@ -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
+ test-support/DeltaLaws.hs view
@@ -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
+ test-support/LawManifest.hs view
@@ -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
+ test-support/PatchReference.hs view
@@ -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 #-}+
+ test/aggregate/Main.hs view
@@ -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+      ]
+ test/core/CoreTests.hs view
@@ -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)
+ test/core/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified CoreTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain CoreTests.tests
+ test/epoch/ComposeSpec.hs view
@@ -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
+ test/epoch/ConstructionSpec.hs view
@@ -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))
+ test/epoch/EpochSupport/Expected.hs view
@@ -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)
+ test/epoch/EpochSupport/Generators.hs view
@@ -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)
+ test/epoch/EpochSupport/Mapping.hs view
@@ -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)
+ test/epoch/EpochSupport/Reference.hs view
@@ -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)]+    ]
+ test/epoch/EpochSupport/Types.hs view
@@ -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)
+ test/epoch/EpochTests.hs view
@@ -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+    ]
+ test/epoch/FiniteSpec.hs view
@@ -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]
+ test/epoch/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified EpochTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain EpochTests.tests
+ test/epoch/ProjectionSpec.hs view
@@ -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+        )
+ test/epoch/TransportSpec.hs view
@@ -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
+ test/epoch/VersionSpec.hs view
@@ -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
+ test/epoch/ViewSpec.hs view
@@ -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)
+ test/laws/CrossCarrierLaws.hs view
@@ -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))
+ test/laws/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified CrossCarrierLaws+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain CrossCarrierLaws.tests
+ test/patch/CodecSpec.hs view
@@ -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]+    ]
+ test/patch/DeltaHashSpec.hs view
@@ -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
+ test/patch/LawsSpec.hs view
@@ -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
+ test/patch/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified PatchTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain PatchTests.tests
+ test/patch/PatchLaws.hs view
@@ -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)
+ test/patch/PatchSupport.hs view
@@ -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+      }
+ test/patch/PatchTests.hs view
@@ -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+    ]
+ test/patch/ReferenceSpec.hs view
@@ -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])+  ]
+ test/patch/ReplaySpec.hs view
@@ -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
+ test/patch/SemanticsSpec.hs view
@@ -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
+ test/repair/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified RepairTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain RepairTests.tests
+ test/repair/RepairTests.hs view
@@ -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