packages feed

moonlight-core (empty) → 0.1.0.0

raw patch · 160 files changed

+22493/−0 lines, 160 filesdep +QuickCheckdep +basedep +bytestring

Dependencies added: QuickCheck, base, bytestring, comonad, containers, data-fix, deepseq, equivalence, filepath, free, memory, moonlight-core, primitive, recursion-schemes, scientific, tasty, tasty-bench, tasty-hunit, tasty-quickcheck, text, these, transformers, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,28 @@+# Changelog++## 0.1.0.0 - 2026-07-12++- Initial release of the Level-0 foundation: the numeric tower (`Scalar`,+  `Numeric`) and its scalar type classes (`AdditiveGroup`,+  `MultiplicativeMonoid`, `Ring`, `Field`, `Metric`, ordered and continuous+  fields), with instances for the primitive numeric types.+- Approximate equality with absolute, relative, and ULP tolerance kinds+  (`ApproxEq`).+- Canonical and exact numeric representations (`CanonicalNumber`, `Canon`,+  `ExactToken`), including one self-delimiting structural sequence grammar.+- Order and reachability: partial-order classes (`Order`), finite universes+  (`Finite`), bounded fixpoint combinators (`Fixpoint`), and persistent+  union-find (`UnionFind`) with checked persistent and transactional class-id+  allocation.+- Identity and lookup: stable structural hashing (`StableHash`, `Hash`), checked+  total registries (`TotalRegistry`), and the relational term database+  (`Term.Database`).+- Syntax layer: Moonlight-owned authored patterns (`PatternVar`, `PatternNode`),+  `Language`/`ZipMatch`, typed substitutions, structural theories whose+  canonicalization reads node children through `Foldable`, and `Fix.Order`.+- Pure proof-manifest rendering/parsing for the EGraph emitter and Rewrite-owned+  external proof boundary; package-local law tests do not impersonate that+  integration.+- `Moonlight.Core` is the aggregate public surface. Public named sublibraries+  provide syntax, pattern automata, and the host-neutral e-graph program+  algebra; `Moonlight.Core.Unsound` provides the explicit trust boundary.
+ 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,157 @@+# moonlight-core++> Part of **Moonlight**, the sheaf-theoretic computation layer beneath+> [Melusine](https://bluerose.blue) and Pale Meridian.++`moonlight-core` is Moonlight's foundation tier.+It is the total vocabulary every layer above shares: numeric classes, structural+identity, orders, patterns, fixpoints, persistent union-find, finite registries, a+term database, and a host-neutral e-graph program algebra.++## Main idea++Every name reachable from the one import, `Moonlight.Core`, is total. Failure is a+value in the return type: `tryInv` returns `Maybe`, `makeSet` returns+`Either UnionFindAllocationError`, `fixpointBounded` returns+`Either (FixpointDivergence a)`, `mkTotalRegistry` returns `Either [missingKey]`.+Operations with no failure case (`magnitude`, `neg`, `union`) return bare values.++`Moonlight.Core.Unsound` holds the unchecked constructors: importing it by name+asserts a refinement the checker cannot see. Every other constructor reachable+through the umbrella validates at construction.++## Use++```haskell+import Moonlight.Core++reciprocalOfThree :: Maybe Double+reciprocalOfThree = tryInv 3++size :: Double+size = magnitude (neg (2.5 :: Double))+```++## Cookbook++Each recipe shows the main idea in practice: the total path returns a value, the+failure path returns a typed sum.++### Persistent union-find++`makeSet` mints fresh classes through a checked allocation boundary, `union`+merges them, and the structure is persistent; older versions stay valid after a+merge.++```haskell+import Moonlight.Core++partition :: Either UnionFindAllocationError (Bool, Bool)+partition = do+  (a, uf1) <- makeSet emptyUnionFind+  (b, uf2) <- makeSet uf1+  (c, uf3) <- makeSet uf2+  let uf = union a b uf3+  pure (equivalent a b uf, equivalent a c uf)   -- Right (True, False)+```++### Bounded fixpoints++`fixpointBounded` iterates a step to a fixed point under an explicit fuel bound.+Non-convergence returns a typed `Left`.++```haskell+import Moonlight.Core++converge :: Either (FixpointDivergence Int) Int+converge = fixpointBounded 100 (\n -> n `div` 2) 37   -- Right 0++diverges :: Either (FixpointDivergence Int) Int+diverges = fixpointBounded 5 (+1) 0                   -- Left (out of fuel)+```++### Checked total maps++`mkTotalRegistry` demands every key of a finite universe; a gap is a typed+`Left [missingKeys]`. In exchange, `lookupTotal` returns a bare value once the+registry is constructed.++```haskell+import Moonlight.Core+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map++data Slot = Alpha | Beta | Gamma+  deriving (Eq, Ord, Show)++instance FiniteUniverse Slot where+  finiteUniverse = Alpha :| [Beta, Gamma]++palette :: Either [Slot] (TotalRegistry Slot String)+palette = mkTotalRegistry (Map.fromList [(Alpha, "a"), (Beta, "b"), (Gamma, "c")])++labelOfBeta :: Either [Slot] String+labelOfBeta = fmap (\reg -> lookupTotal reg Beta) palette   -- Right "b"+-- mkTotalRegistry (Map.fromList [(Alpha, "a")])  ==  Left [Beta, Gamma]+```++### The matching seam++`ZipMatch` is one-layer structural matching: `zipMatch` succeeds iff two nodes share a+shape, pairing their children positionally. It is the seam the e-graph and rewriting+layers are built on.++```haskell+import Moonlight.Core++data ExprF a = Lit Int | Add a a+  deriving (Functor, Foldable, Traversable, Eq, Ord, Show)++instance ZipMatch ExprF where+  zipMatch (Lit m)     (Lit n)     | m == n = Just (Lit m)+  zipMatch (Add a1 b1) (Add a2 b2)          = Just (Add (a1, a2) (b1, b2))+  zipMatch _           _                    = Nothing++aligned :: Maybe (ExprF (Int, Int))+aligned = zipMatch (Add 1 2) (Add 10 20)   -- Just (Add (1,10) (2,20))+```++## Surface & boundaries++Most downstream code imports the umbrella. Lower-level packages may depend on one+of the public sublibraries.++| Cabal dependency | Import | What you get |+| --- | --- | --- |+| `moonlight-core` | `Moonlight.Core` | The ordinary total vocabulary. This is the default. |+| `moonlight-core:moonlight-core-syntax` | `Moonlight.Core.Pattern.AntiUnify` | Patterns and term anti-unification without the full umbrella. |+| `moonlight-core:moonlight-core-automata` | `Moonlight.Core.Pattern.Automata` or `.Kernel` | The bottom-up automata substrate and compiled matcher. Depend on syntax too when naming its types directly. |+| `moonlight-core:moonlight-core-egraph-program` | `Moonlight.Core.EGraph.Program` | The host-neutral e-graph program algebra without the rest of the foundation. |+| `moonlight-core` | `Moonlight.Core.Unsound` | The explicit trust boundary; see [Main idea](#main-idea). |++The private implementation slices remain **basis**, **numeric**, **solver**, and+**term**. Syntax, automata, and e-graph programs are public because other foundation+packages consume those exact owners. The umbrella re-exports the+syntax and e-graph-program vocabulary; automata are imported only through the sublibrary.+Haddock carries the signatures; the laws are named and machine-checked in the law suites.++## Test++```bash+cabal test moonlight-core:moonlight-core-test+```++## Benchmarks++```bash+cabal bench moonlight-core:moonlight-core-bench --benchmark-options='--timeout=2s --csv=comparison.csv'+```++`hackage:` rows measure a package-level baseline (`containers`, `memory`, `scientific`,+`equivalence`) on the same fixture; `world:` rows are source-equivalent baselines where+no package owner exists. Fixtures assert result agreement with the baseline before+timing. Dated receipts live in `docs/BENCHMARKS-m4-pro.md`.++## License++MIT. See `LICENSE`.
+ bench/aggregate/Main.hs view
@@ -0,0 +1,21 @@+module Main+  ( main,+  )+where++import NumericBench (numericBenchmarks)+import SolverBench (solverBenchmarks)+import BasisBench (basisBenchmarks)+import SyntaxBench (syntaxBenchmarks)+import TermBench (termBenchmarks)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain+    [ basisBenchmarks,+      numericBenchmarks,+      syntaxBenchmarks,+      solverBenchmarks,+      termBenchmarks+    ]
+ bench/basis/BasisBench.hs view
@@ -0,0 +1,553 @@+{-# LANGUAGE DerivingStrategies #-}++module BasisBench+  ( basisBenchmarks,+  )+where++import Control.DeepSeq+  ( NFData (..),+  )+import Data.ByteArray.Hash+  ( SipHash (..),+    sipHash,+  )+import Data.ByteString+  ( ByteString,+  )+import Data.ByteString qualified as ByteString+import Data.ByteString.Char8 qualified as ByteString.Char8+import Data.ByteString.Builder qualified as Builder+import Data.ByteString.Lazy qualified as LazyByteString+import Data.Functor.Identity+  ( Identity (..),+    runIdentity,+  )+import Data.List qualified as List+import Data.List.NonEmpty+  ( NonEmpty,+  )+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text+  ( Text,+  )+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TextEncoding+import Data.Word+  ( Word64,+    Word8,+  )+import Moonlight.Core+  ( adjacentPairs,+    averageOf,+    safeIndex,+  )+import BenchSupport+  ( caseLabel,+    foundationSizes,+    keys,+  )+import Moonlight.Core+  ( FiniteUniverse (..),+    boundedEnumUniverse,+  )+import Moonlight.Core+  ( accumByKey,+    groupByKey,+  )+import Moonlight.Core+  ( StableHashDigest (..),+    SipHashState,+    defaultStableHashKey,+    sipHashFinalize,+    sipHashInit,+    sipHashUpdateWord64Dec,+    sipHashUpdateWord64LE,+    stableHashByteStrings,+    stableHashEncodingChunks,+    stableHashEncodingTextUtf8,+    stableHashEncodingVersion,+    stableHashEncodingWord64Dec,+    sipHashUpdateWord8,+  )+import Moonlight.Core+  ( TotalRegistry,+    lookupTotal,+    mkTotalRegistry,+  )+import Moonlight.Core+  ( collectEither,+  )+import Moonlight.Core+  ( ProofManifestError (..),+    Queue,+    dedupStableOn,+    dequeue,+    duplicateValuesOn,+    duplicatesOrd,+    emptyQueue,+    enqueueAll,+    firstDuplicate,+    invertMapOfSets,+    canonicalTheoremManifestNames,+    parseTheoremManifestNames,+    queueFromList,+    renderTheoremManifestJson,+    scanFoldM,+    scanMap,+    unfoldM,+  )+import Test.Tasty.Bench+  ( Benchmark,+    bench,+    bgroup,+    env,+    nf,+  )+import Prelude++basisBenchmarks :: Benchmark+basisBenchmarks =+  bgroup+    "basis"+    ( (foundationSizes >>= basisBenchmarksForSize)+        <> (proofManifestSizes >>= proofManifestBenchmarksForSize)+        <> [bench (caseLabel "proof manifest canonical names" 8000) (nf proofManifestCanonicalWeight 8000)]+    )++basisBenchmarksForSize :: Int -> [Benchmark]+basisBenchmarksForSize size =+  [ bench (caseLabel "stable hash byte chunks" size) (nf stableHashTokenWeight size),+    env (pure (stableHashChunkCorpus size)) $ \chunks ->+      bench (caseLabel "stable hash prepared byte chunks" size) (nf stableHashPreparedTokenWeight chunks),+    env (pure (stableHashWideChunkCorpus size)) $ \chunks ->+      bench (caseLabel "stable hash prepared wide byte chunks" size) (nf stableHashPreparedTokenWeight chunks),+    bench (caseLabel "stable hash direct decimal word chunks" size) (nf stableHashDecimalWordTokenWeight size),+    bench (caseLabel "stable hash direct raw decimal token bytes" size) (nf stableHashRawDecimalTokenWeight size),+    bench (caseLabel "stable hash direct utf8 text chunks" size) (nf stableHashTextEncodingTokenWeight size),+    bench (caseLabel "stable hash utf8 text byte chunks" size) (nf stableHashTextByteTokenWeight size),+    bench (caseLabel "hackage: memory SipHash framed byte chunks" size) (nf hackageMemorySipHashFramedChunksWeight size),+    env (pure (framedChunkPayload (stableHashChunkCorpus size))) $ \payload ->+      bench (caseLabel "hackage: memory SipHash prepared framed bytes" size) (nf hackageMemorySipHashPreparedPayloadWeight payload),+    env (pure (framedChunkPayload (stableHashWideChunkCorpus size))) $ \payload ->+      bench (caseLabel "hackage: memory SipHash prepared wide framed bytes" size) (nf hackageMemorySipHashPreparedPayloadWeight payload),+    bench (caseLabel "hackage: memory SipHash raw token bytes" size) (nf hackageMemorySipHashWeight size),+    env (pure (rawTokenPayload size)) $ \payload ->+      bench (caseLabel "hackage: memory SipHash prepared raw token bytes" size) (nf hackageMemorySipHashPreparedPayloadWeight payload),+    bench (caseLabel "map accumulation" size) (nf mapAccumWeight size),+    bench (caseLabel "hackage: containers Map.fromListWith group+accum" size) (nf hackageContainersAccumWeight size),+    bench (caseLabel "total registry lookup sweep" size) (nf registryLookupSweepWeight size),+    bench (caseLabel "hackage: containers Map.lookup sweep" size) (nf hackageRegistryLookupSweepWeight size),+    bench (caseLabel "validation collect" size) (nf validationCollectWeight size),+    bench (caseLabel "hackage/base: Either short-circuit traverse" size) (nf hackageEitherTraverseWeight size),+    bench (caseLabel "aggregate adjacent/safe-index" size) (nf aggregateWeight size),+    bench (caseLabel "queue enqueue/drain" size) (nf queueEnqueueDrainWeight size),+    bench (caseLabel "queue from-list/drain" size) (nf queueFromListDrainWeight size),+    bench (caseLabel "dedup stable/duplicate detection" size) (nf dedupWeight size),+    bench (caseLabel "map invert set adjacency" size) (nf mapInvertWeight size),+    bench (caseLabel "scan map/fold/unfold" size) (nf scanWeight size)+  ]++proofManifestBenchmarksForSize :: Int -> [Benchmark]+proofManifestBenchmarksForSize size =+  [ bench (caseLabel "proof manifest canonical names" size) (nf proofManifestCanonicalWeight size),+    bench (caseLabel "proof manifest render/parse" size) (nf proofManifestRoundtripWeight size),+    bench (caseLabel "proof manifest reject invalid payloads" size) (nf proofManifestRejectWeight size)+  ]++proofManifestSizes :: [Int]+proofManifestSizes =+  [32, 128, 512]++proofManifestCanonicalWeight :: Int -> Int+proofManifestCanonicalWeight =+  sum . fmap length . canonicalTheoremManifestNames . theoremNamesForSize++stableHashTokenWeight :: Int -> Int+stableHashTokenWeight size =+  case stableHashByteStrings (stableHashChunkCorpus size) of+    StableHashDigest digest -> fromIntegral digest++stableHashPreparedTokenWeight :: [ByteString] -> Int+stableHashPreparedTokenWeight chunks =+  case stableHashByteStrings chunks of+    StableHashDigest digest -> fromIntegral digest++stableHashTextEncodingTokenWeight :: Int -> Int+stableHashTextEncodingTokenWeight size =+  case stableHashEncodingChunks stableHashEncodingTextUtf8 (stableHashTextCorpus size) of+    StableHashDigest digest -> fromIntegral digest++stableHashDecimalWordTokenWeight :: Int -> Int+stableHashDecimalWordTokenWeight size =+  case stableHashEncodingChunks (stableHashEncodingWord64Dec . fromIntegral) (keys size) of+    StableHashDigest digest -> fromIntegral digest++stableHashRawDecimalTokenWeight :: Int -> Int+stableHashRawDecimalTokenWeight size =+  fromIntegral (sipHashFinalize (foldl' absorbToken seededState (keys size)))+  where+    seededState =+      sipHashUpdateWord64LE (sipHashInit defaultStableHashKey) stableHashEncodingVersion+    absorbToken :: SipHashState -> Int -> SipHashState+    absorbToken state key =+      sipHashUpdateWord8+        (sipHashUpdateWord64Dec state (fromIntegral key))+        0++stableHashTextByteTokenWeight :: Int -> Int+stableHashTextByteTokenWeight size =+  case stableHashByteStrings (fmap TextEncoding.encodeUtf8 (stableHashTextCorpus size)) of+    StableHashDigest digest -> fromIntegral digest++stableHashTextCorpus :: Int -> [Text]+stableHashTextCorpus =+  fmap (Text.pack . show) . keys++stableHashChunkCorpus :: Int -> [ByteString]+stableHashChunkCorpus =+  fmap stableHashChunkToken . keys++stableHashWideChunkCorpus :: Int -> [ByteString]+stableHashWideChunkCorpus =+  fmap stableHashWideChunkToken . keys++stableHashChunkToken :: Int -> ByteString+stableHashChunkToken =+  ByteString.Char8.pack . show++stableHashWideChunkToken :: Int -> ByteString+stableHashWideChunkToken key =+  ByteString.replicate 128 (fromIntegral (key `mod` 251))++hackageMemorySipHashWeight :: Int -> Int+hackageMemorySipHashWeight size =+  case sipHash defaultStableHashKey (rawTokenPayload size) of+    SipHash digest -> fromIntegral digest++hackageMemorySipHashFramedChunksWeight :: Int -> Int+hackageMemorySipHashFramedChunksWeight =+  hackageMemorySipHashPreparedPayloadWeight . framedChunkPayload . stableHashChunkCorpus++hackageMemorySipHashPreparedPayloadWeight :: ByteString -> Int+hackageMemorySipHashPreparedPayloadWeight payload =+  case sipHash defaultStableHashKey payload of+    SipHash digest -> fromIntegral digest++framedChunkPayload :: [ByteString] -> ByteString+framedChunkPayload chunks =+  LazyByteString.toStrict+    ( Builder.toLazyByteString+        ( Builder.word64LE stableHashEncodingVersion+            <> compactWord64Builder (fromIntegral (length chunks))+            <> foldMap framedChunkBuilder chunks+        )+    )++framedChunkBuilder :: ByteString -> Builder.Builder+framedChunkBuilder chunk =+  compactWord64Builder (fromIntegral (ByteString.length chunk))+    <> Builder.byteString chunk++compactWord64Builder :: Word64 -> Builder.Builder+compactWord64Builder wordValue =+  let byteValue =+        fromIntegral (wordValue `rem` 128)+      remainingValue =+        wordValue `quot` 128+   in if remainingValue == 0+        then Builder.word8 byteValue+        else Builder.word8 (byteValue + 128) <> compactWord64Builder remainingValue++rawTokenPayload :: Int -> ByteString+rawTokenPayload =+  LazyByteString.toStrict+    . Builder.toLazyByteString+    . foldMap rawTokenBuilder+    . keys++rawTokenBuilder :: Int -> Builder.Builder+rawTokenBuilder key =+  Builder.intDec key <> Builder.char7 '\0'++mapAccumWeight :: Int -> Int+mapAccumWeight size =+  let grouped = groupByKey (`mod` 17) (keys size)+      accumulated = accumByKey (`mod` 31) SumValue (keys size)+   in Map.size grouped + sumValueMapDigest accumulated++hackageContainersAccumWeight :: Int -> Int+hackageContainersAccumWeight size =+  Map.size grouped + sumValueMapDigest accumulated+  where+    grouped =+      Map.fromListWith+        (++)+        [ (key `mod` 17, [key])+        | key <- keys size+        ]+    accumulated =+      Map.fromListWith+        (<>)+        [ (key `mod` 31, SumValue key)+        | key <- keys size+        ]++newtype SumValue = SumValue {unSumValue :: Int}+  deriving stock (Eq, Show)++instance Semigroup SumValue where+  SumValue left <> SumValue right =+    SumValue (left + right)++newtype BenchRegistryKey = BenchRegistryKey+  { unBenchRegistryKey :: Word8+  }+  deriving stock (Eq, Ord, Show)++instance FiniteUniverse BenchRegistryKey where+  finiteUniverse =+    fmap BenchRegistryKey (boundedEnumUniverse :: NonEmpty Word8)++registryLookupSweepWeight :: Int -> Int+registryLookupSweepWeight size =+  case benchTotalRegistry of+    Left missingKeys -> length missingKeys+    Right registry ->+      sum+        [ lookupTotal registry (registryKeyAt index)+        | index <- keys size+        ]++hackageRegistryLookupSweepWeight :: Int -> Int+hackageRegistryLookupSweepWeight size =+  sum+    [ maybe 0 id (Map.lookup (registryKeyAt index) benchRegistryMap)+    | index <- keys size+    ]++benchTotalRegistry :: Either [BenchRegistryKey] (TotalRegistry BenchRegistryKey Int)+benchTotalRegistry =+  mkTotalRegistry benchRegistryMap++registryKeyAt :: Int -> BenchRegistryKey+registryKeyAt index =+  BenchRegistryKey (fromIntegral (index `mod` 256))++benchRegistryMap :: Map.Map BenchRegistryKey Int+benchRegistryMap =+  Map.fromList (fmap registryEntry [minBound .. maxBound])+  where+    registryEntry :: Word8 -> (BenchRegistryKey, Int)+    registryEntry key =+      (BenchRegistryKey key, fromIntegral key * 31 + 7)++validationCollectWeight :: Int -> Int+validationCollectWeight size =+  case collectEither (fmap validateEven (keys size)) of+    Left rejected -> length rejected+    Right accepted -> length accepted++hackageEitherTraverseWeight :: Int -> Int+hackageEitherTraverseWeight size =+  case traverse validateEven (keys size) of+    Left rejected -> length rejected+    Right accepted -> length accepted++validateEven :: Int -> Either [Int] Int+validateEven value+  | even value = Right value+  | otherwise = Left [value]++aggregateWeight :: Int -> Int+aggregateWeight size =+  let values = keys size+      maybeAverage = averageOf (fmap fromIntegral values)+      maybeIndexed = safeIndex (size `div` 2) values+   in length (adjacentPairs values)+        + maybe 0 round maybeAverage+        + maybe 0 id maybeIndexed++queueEnqueueDrainWeight :: Int -> Int+queueEnqueueDrainWeight size =+  drainQueue (enqueueAll (keys size) emptyQueue)++queueFromListDrainWeight :: Int -> Int+queueFromListDrainWeight =+  drainQueue . queueFromList . keys++drainQueue :: Queue Int -> Int+drainQueue =+  sum . List.unfoldr dequeue++dedupWeight :: Int -> Int+dedupWeight size =+  length (dedupStableOn id payload)+    + length (duplicatesOrd payload)+    + length (duplicateValuesOn id payload)+    + maybe 0 id (firstDuplicate payload)+  where+    payload =+      duplicatePayload size++duplicatePayload :: Int -> [Int]+duplicatePayload size =+  fmap (`mod` bucketCount) (keys size <> keys size)+  where+    bucketCount =+      max 1 (size `div` 4)++mapInvertWeight :: Int -> Int+mapInvertWeight size =+  Map.size inverted + sum (fmap Set.size (Map.elems inverted))+  where+    inverted =+      invertMapOfSets (setAdjacencyMap size)++setAdjacencyMap :: Int -> Map.Map Int (Set.Set Int)+setAdjacencyMap size =+  Map.fromList (fmap adjacencyEntry (keys size))+  where+    bucketCount =+      max 1 (size `div` 8)+    adjacencyEntry key =+      ( key,+        Set.fromList+          [ key `mod` bucketCount,+            (key + 3) `mod` bucketCount,+            (key * 7 + 1) `mod` bucketCount+          ]+      )++scanWeight :: Int -> Int+scanWeight size =+  finalState + sum mappedValues + foldedValue + sum unfoldedValues+  where+    (finalState, mappedValues) =+      scanMap scanStep 0 (keys size)+    foldedValue =+      runIdentity (scanFoldM scanFoldStep 0 (keys size))+    unfoldedValues =+      runIdentity (unfoldM unfoldIdentityStep size)++scanStep :: Int -> Int -> (Int, Int)+scanStep state value =+  let nextState = state + value+   in (nextState, nextState `mod` 97)++scanFoldStep :: Int -> Int -> Identity Int+scanFoldStep state value =+  Identity (state + value `mod` 31)++unfoldIdentityStep :: Int -> Identity (Maybe (Int, Int))+unfoldIdentityStep remaining+  | remaining <= 0 = Identity Nothing+  | otherwise = Identity (Just (remaining, remaining - 1))++data ProofManifestBenchMeasure+  = ProofManifestBenchMeasured !Int+  | ProofManifestBenchParseFailed !ProofManifestError+  | ProofManifestBenchUnexpectedAccept ![String]+  deriving stock (Eq, Show)++instance NFData ProofManifestBenchMeasure where+  rnf measure =+    case measure of+      ProofManifestBenchMeasured weightValue ->+        rnf weightValue+      ProofManifestBenchParseFailed failure ->+        rnfProofManifestError failure+      ProofManifestBenchUnexpectedAccept accepted ->+        rnf accepted++proofManifestRoundtripWeight :: Int -> ProofManifestBenchMeasure+proofManifestRoundtripWeight size =+  case parseTheoremManifestNames rendered of+    Left failure ->+      ProofManifestBenchParseFailed failure+    Right parsedNames ->+      ProofManifestBenchMeasured+        ( length rendered+            + length parsedNames+            + codecAgreementWeight theoremNames parsedNames+        )+  where+    theoremNames =+      theoremNamesForSize size+    rendered =+      renderTheoremManifestJson theoremNames++proofManifestRejectWeight :: Int -> ProofManifestBenchMeasure+proofManifestRejectWeight size =+  either+    ProofManifestBenchUnexpectedAccept+    (ProofManifestBenchMeasured . sum)+    (traverse invalidManifestPayloadWeight (invalidManifestPayloads size))++invalidManifestPayloadWeight :: String -> Either [String] Int+invalidManifestPayloadWeight payload =+  case parseTheoremManifestNames payload of+    Left failure ->+      Right (proofManifestErrorWeight failure)+    Right accepted ->+      Left accepted++codecAgreementWeight :: [String] -> [String] -> Int+codecAgreementWeight required actual =+  if canonicalTheoremManifestNames required == actual+    then 1+    else 0++theoremNamesForSize :: Int -> [String]+theoremNamesForSize size =+  fmap theoremNameForKey (keys size)++theoremNameForKey :: Int -> String+theoremNameForKey key =+  "Moonlight.Core.Generated.Theorem."+    <> show key+    <> ".escaped\\quote\""++invalidManifestPayloads :: Int -> [String]+invalidManifestPayloads size =+  [ "{\"theorems\":[alpha]}",+    "{\"laws\":[\"alpha\"]}",+    "{\"theorems\":[\"\"]}",+    "{\"theorems\":[\" alpha\"]}",+    "{\"theorems\":[\"alpha\",\"alpha\"]}",+    "{\"theorems\":[\""+      <> theoremNameForKey size+      <> "\n\"]}",+    "{\"theorems\":[\"\\uD800\"]}"+  ]++proofManifestErrorWeight :: ProofManifestError -> Int+proofManifestErrorWeight failure =+  case failure of+    ProofManifestParseFailure ->+      1+    EmptyTheoremManifestName ->+      2+    WhitespacePaddedTheoremManifestName theoremName ->+      3 + length theoremName+    DuplicateTheoremManifestName theoremName ->+      5 + length theoremName++rnfProofManifestError :: ProofManifestError -> ()+rnfProofManifestError failure =+  case failure of+    ProofManifestParseFailure ->+      ()+    EmptyTheoremManifestName ->+      ()+    WhitespacePaddedTheoremManifestName theoremName ->+      rnf theoremName+    DuplicateTheoremManifestName theoremName ->+      rnf theoremName++sumValueMapDigest :: Map.Map Int SumValue -> Int+sumValueMapDigest =+  Map.foldlWithKey'+    (\digest key (SumValue value) -> digest * 16777619 + key * 31 + value)+    146959810
+ bench/basis/Main.hs view
@@ -0,0 +1,11 @@+module Main+  ( main,+  )+where++import BasisBench (basisBenchmarks)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [basisBenchmarks]
+ bench/numeric/Main.hs view
@@ -0,0 +1,11 @@+module Main+  ( main,+  )+where++import NumericBench (numericBenchmarks)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [numericBenchmarks]
+ bench/numeric/NumericBench.hs view
@@ -0,0 +1,169 @@+module NumericBench+  ( numericBenchmarks,+  )+where++import Data.ByteString.Builder qualified as Builder+import Data.ByteString.Lazy qualified as LazyByteString+import Data.Scientific qualified as Scientific+import Data.Word+  ( Word32,+  )+import Moonlight.Core+  ( AbsTol,+    ApproxEq (..),+    absTol,+  )+import BenchSupport+  ( caseLabel,+    keys,+    numericSizes,+    showLength,+  )+import Moonlight.Core+  ( canonicalize,+    quantizeForHash,+  )+import Moonlight.Core+  ( CanonicalNumber,+    canonicalNumberToMaybeDouble,+    mkCanonicalFiniteNumber,+  )+import Moonlight.Core+  ( ExactEncoding,+    ExactEncodingAtom (..),+    exactAtomEncoding,+    exactSequenceMapEncoding,+    exactTokenFromEncoding,+    exactTokenLength,+  )+import Moonlight.Core+  ( MoonlightError,+  )+import Moonlight.Core+  ( AdditiveGroup (..),+    AdditiveMonoid (..),+    MultiplicativeMonoid (..),+  )+import Test.Tasty.Bench+  ( Benchmark,+    bench,+    bgroup,+    nf,+  )+import Prelude++numericBenchmarks :: Benchmark+numericBenchmarks =+  bgroup+    "numeric"+    (numericSizes >>= numericBenchmarksForSize)++numericBenchmarksForSize :: Int -> [Benchmark]+numericBenchmarksForSize size =+  [ bench (caseLabel "canonicalize doubles" size) (nf canonicalizeWeight size),+    bench (caseLabel "quantize doubles" size) (nf quantizeWeight size),+    bench (caseLabel "canonical finite numbers" size) (nf canonicalNumberWeight size),+    bench (caseLabel "hackage: scientific fromFloatDigits" size) (nf hackageScientificFromFloatDigitsWeight size),+    bench (caseLabel "scalar class operations" size) (nf scalarClassWeight size),+    bench (caseLabel "approximate equality" size) (nf approximateEqualityWeight size),+    bench (caseLabel "structural exact token construction" size) (nf exactTokenWeight size),+    bench (caseLabel "hackage: bytestring Builder counted ints" size) (nf hackageBuilderCountedIntsWeight size)+  ]++canonicalizeWeight :: Int -> Int+canonicalizeWeight size =+  eitherFoldWeight round (traverse canonicalize (benchDoubles size))++quantizeWeight :: Int -> Int+quantizeWeight size =+  eitherFoldWeight fromIntegral (traverse (quantizeForHash benchPrecision) (benchDoubles size))++canonicalNumberWeight :: Int -> Int+canonicalNumberWeight size =+  eitherValueWeight id (fmap canonicalNumberDigest (traverse mkCanonicalFiniteNumber (benchDoubles size)))++hackageScientificFromFloatDigitsWeight :: Int -> Integer+hackageScientificFromFloatDigitsWeight =+  foldl' scientificDigest 146959810+    . fmap (Scientific.normalize . Scientific.fromFloatDigits)+    . benchDoubles++scientificDigest :: Integer -> Scientific.Scientific -> Integer+scientificDigest digest scientificValue =+  digest * 16777619+    + Scientific.coefficient scientificValue+    + fromIntegral (Scientific.base10Exponent scientificValue)++scalarClassWeight :: Int -> Double+scalarClassWeight size =+  let values = benchDoubles size+      additiveTotal = foldl' add zero values+      multiplicativeTotal = foldl' mul one (fmap normalizedFactor values)+   in sub additiveTotal multiplicativeTotal++approximateEqualityWeight :: Int -> Int+approximateEqualityWeight size =+  case benchAbsTol of+    Left err -> showLength (show err)+    Right tolerance ->+      length+        [ ()+        | value <- benchDoubles size,+          approxEq tolerance value (value + 0.000001)+        ]++exactTokenWeight :: Int -> Int+exactTokenWeight =+  eitherValueWeight id . exactTokenLength . exactTokenFromEncoding . exactTokenEncoding++hackageBuilderCountedIntsWeight :: Int -> Int+hackageBuilderCountedIntsWeight =+  fromIntegral+    . LazyByteString.length+    . Builder.toLazyByteString+    . countedIntsBuilder++countedIntsBuilder :: Int -> Builder.Builder+countedIntsBuilder size =+  Builder.int64BE (fromIntegral size)+    <> foldMap (Builder.int64BE . fromIntegral) (keys size)++exactTokenEncoding :: Int -> ExactEncoding+exactTokenEncoding size =+  exactSequenceMapEncoding (exactAtomEncoding . ExactInt) (keys size)++canonicalNumberDigest :: [CanonicalNumber] -> Int+canonicalNumberDigest =+  foldl'+    ( \digest number ->+        digest * 16777619 + maybe 0 round (canonicalNumberToMaybeDouble number)+    )+    146959810++benchDoubles :: Int -> [Double]+benchDoubles size =+  fmap (\key -> fromIntegral key / 10.0) (keys size)++normalizedFactor :: Double -> Double+normalizedFactor value =+  1.0 + value / 1000000.0++benchPrecision :: Word32+benchPrecision = 4++benchAbsTol :: Either MoonlightError AbsTol+benchAbsTol =+  absTol 0.001++eitherFoldWeight :: (Foldable values, Show err) => (value -> Int) -> Either err (values value) -> Int+eitherFoldWeight project eitherValue =+  case eitherValue of+    Left err -> showLength (show err)+    Right values -> foldl' (\total value -> total + project value) 0 values++eitherValueWeight :: Show err => (value -> Int) -> Either err value -> Int+eitherValueWeight project eitherValue =+  case eitherValue of+    Left err -> showLength (show err)+    Right value -> project value
+ bench/solver/Main.hs view
@@ -0,0 +1,11 @@+module Main+  ( main,+  )+where++import SolverBench (solverBenchmarks)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [solverBenchmarks]
+ bench/solver/SolverBench.hs view
@@ -0,0 +1,645 @@+{-# LANGUAGE RankNTypes #-}++module SolverBench+  ( solverBenchmarks,+  )+where++import Control.DeepSeq+  ( NFData (..),+  )+import Control.Monad.ST+  ( ST,+  )+import Data.Equivalence.Monad qualified as Equivalence+import Data.Foldable+  ( traverse_,+  )+import Data.Graph qualified as Graph+import Data.IntMap.Strict+  ( IntMap,+  )+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet+  ( IntSet,+  )+import Data.IntSet qualified as IntSet+import Data.Vector qualified as Vector+import BenchSupport+  ( caseLabel,+    foundationSizes,+    keys,+    sampleKeys,+    showLength,+    unionFindSizes,+  )+import Moonlight.Core+  ( DeltaDomain (..),+    EquationId (..),+    Evaluation,+    closureUnderInt,+    fixpointBounded,+    readEquationValue,+    resultValues,+    solveDenseMonotone,+    traverseOnceIntSet,+  )+import Moonlight.Core.Fixpoint.Dense+  ( Csr,+    csrOffsets,+    csrTargets,+    csrTranspose,+    csrVertexCount,+    FrozenDigraph,+    graphBackward,+    graphForward,+    graphSccPlan,+    SccClosureCache,+    SccPlan,+    condensation,+    condensationBackward,+    sccMembers,+    sccOfVertex,+    sccClosureCacheFor,+    Edge (..),+    frozenDigraphFromSuccessors,+    frozenReachabilityFrom,+    frozenReachabilityWithCache,+    snapshotFromFrozen,+    snapshotReachabilityFrom,+    insertSnapshotEdge,+  )+import Moonlight.Core+  ( ClassId (..),+    classIdKey,+  )+import Moonlight.Core qualified as UF+import Moonlight.Core qualified as UFT+import Test.Tasty.Bench+  ( Benchmark,+    bench,+    bgroup,+    env,+    nf,+  )+import Prelude++newtype ContainersUnionFind = ContainersUnionFind (IntMap Int)++newtype ForcedFrozenDigraph = ForcedFrozenDigraph FrozenDigraph++instance NFData ForcedFrozenDigraph where+  rnf (ForcedFrozenDigraph graph) =+    rnfFrozenDigraph graph++newtype ForcedGraph = ForcedGraph Graph.Graph++instance NFData ForcedGraph where+  rnf (ForcedGraph graph) =+    rnf (Graph.vertices graph, Graph.edges graph)++data ForcedSccClosureCache = ForcedSccClosureCache+  { forcedCacheReceipt :: !Int,+    forcedCache :: !SccClosureCache+  }++instance NFData ForcedSccClosureCache where+  rnf cache =+    rnf (forcedCacheReceipt cache)++solverBenchmarks :: Benchmark+solverBenchmarks =+  bgroup+    "solver"+    [ unionFindBenchmarks,+      fixpointBenchmarks+    ]++unionFindBenchmarks :: Benchmark+unionFindBenchmarks =+  bgroup+    "union-find"+    ( (unionFindSizes >>= unionFindBenchmarksForSize)+        <> (unionFindSizes >>= unionFindKeyDistributionBenchmarksForSize)+    )++unionFindBenchmarksForSize :: Int -> [Benchmark]+unionFindBenchmarksForSize size =+  [ bench (caseLabel "insert+canonical compress" size) (nf unionFindBuildWeight size),+    env (pure (keys size)) $ \ids ->+      bench (caseLabel "union chain/compress" size) (nf unionFindChainWeight ids),+    bench (caseLabel "balanced union/compress" size) (nf balancedUnionFindCompressSizeWeight size),+    bench (caseLabel "transaction balanced union/compress" size) (nf transactionBalancedUnionCompressWeight size),+    bench (caseLabel "transaction prefix+sparse-outlier" size) (nf transactionSparseOutlierWeight size),+    bench (caseLabel "balanced build+cold find sweep" size) (nf balancedColdFindSweepSizeWeight size),+    bench (caseLabel "transaction build+cold find sweep" size) (nf transactionColdFindSweepSizeWeight size),+    bench (caseLabel "balanced build+compressed find sweep" size) (nf balancedCompressedFindSweepSizeWeight size),+    bench (caseLabel "paired build/equivalence sweep" size) (nf pairedUnionFindEquivalenceWeight size),+    bench (caseLabel "world: containers parent-map balanced union/canonical" size) (nf containersUnionFindBalancedWeight size),+    bench (caseLabel "hackage: equivalence balanced union/equivalence sweep" size) (nf hackageEquivalenceUnionFindWeight size)+  ]++unionFindKeyDistributionBenchmarksForSize :: Int -> [Benchmark]+unionFindKeyDistributionBenchmarksForSize size =+  [ env (pure (holeyKeys size)) $ \ids ->+      bench (caseLabel "canonical sweep/50pct holes" size) (nf unionFindCanonicalSweepWeight ids),+    env (pure (negativeKeys size)) $ \ids ->+      bench (caseLabel "canonical sweep/negative keys" size) (nf unionFindCanonicalSweepWeight ids),+    env (pure (densePrefixWithGiantOutlier size)) $ \ids ->+      bench (caseLabel "canonical sweep/dense prefix + giant outlier" size) (nf unionFindCanonicalSweepWeight ids),+    env (pure (mixedDenseSparseKeys size)) $ \ids ->+      bench (caseLabel "canonical sweep/mixed dense sparse" size) (nf unionFindCanonicalSweepWeight ids)+  ]++fixpointBenchmarks :: Benchmark+fixpointBenchmarks =+  bgroup+    "fixpoint-worklists"+    ( (foundationSizes >>= fixpointBenchmarksForSize)+        <> [bench (caseLabel "solveDenseMonotone one-read chain" 16000) (nf denseMonotoneSolverWeight 16000)]+        <> [ env (pure (hotSingletonCache 100000)) $ \cache ->+               bench (caseLabel "frozenReachabilityWithCache hot singleton isolated" 100000) (nf hotSingletonCacheWeight cache)+           ]+        <> (foundationSizes >>= variableDegreeReachabilityBenchmarksForSize)+    )++fixpointBenchmarksForSize :: Int -> [Benchmark]+fixpointBenchmarksForSize size =+  [ bench (caseLabel "solveDenseMonotone one-read chain" size) (nf denseMonotoneSolverWeight size),+    bench (caseLabel "closureUnderInt fanout=2" size) (nf closureWeight size),+    bench (caseLabel "traverseOnceIntSet fanout=2" size) (nf worklistWeight size),+    bench (caseLabel "frozenDigraph build+reach fanout=2" size) (nf denseBuildClosureWeight size),+    env (pure (forcedFrozenDigraphForSize size)) $ \denseRelation ->+      bench (caseLabel "csrTranspose/prebuilt fanout=2" size) (nf denseTransposeWeight denseRelation),+    env (pure (forcedFrozenDigraphForSize size)) $ \denseRelation ->+      bench (caseLabel "frozenReachabilityFrom/prebuilt fanout=2" size) (nf denseClosureWeight denseRelation),+    env (pure (forcedFrozenDigraphForSize size)) $ \denseRelation ->+      bench (caseLabel "frozenReachabilityFrom/prebuilt repeated fanout=2" size) (nf denseRepeatedClosureWeight denseRelation),+    bench (caseLabel "frozenDigraph build+reach cyclic fanout=2" size) (nf denseCyclicBuildClosureWeight size),+    env (pure (forcedFrozenCyclicDigraphForSize size)) $ \denseRelation ->+      bench (caseLabel "frozenReachabilityFrom/prebuilt cyclic fanout=2" size) (nf denseClosureWeight denseRelation),+    bench (caseLabel "frozenDigraph build+reach scc-heavy" size) (nf denseSccHeavyBuildClosureWeight size),+    env (pure (forcedFrozenSccHeavyDigraphForSize size)) $ \denseRelation ->+      bench (caseLabel "frozenReachabilityFrom/prebuilt scc-heavy" size) (nf denseClosureWeight denseRelation),+    env (pure (forcedFrozenSccHeavyDigraphForSize size)) $ \denseRelation ->+      bench (caseLabel "frozenReachabilityWithCache cold/hot scc-heavy" size) (nf denseCachedClosureWeight denseRelation),+    bench (caseLabel "graphSnapshot overlay reachability" size) (nf graphSnapshotOverlayReachabilityWeight size),+    bench (caseLabel "world: containers IntSet reachability fanout=2" size) (nf containersReachabilityWeight size),+    bench (caseLabel "hackage: containers Data.Graph build+reachable fanout=2" size) (nf hackageDataGraphBuildReachabilityWeight size),+    env (pure (forcedHackageDataGraphForSize size)) $ \graph ->+      bench (caseLabel "hackage: containers Data.Graph reachable/prebuilt fanout=2" size) (nf hackageDataGraphReachabilityWeight graph),+    bench (caseLabel "fixpointBounded decrement" size) (nf boundedFixpointWeight size)+  ]++variableDegreeReachabilityBenchmarksForSize :: Int -> [Benchmark]+variableDegreeReachabilityBenchmarksForSize size =+  [ bench (caseLabel "frozenDigraph build+reach var-degree" size) (nf (denseBuildClosureWith variableDegreeSuccessors) size),+    env (pure (forcedFrozenDigraphWith variableDegreeSuccessors size)) $ \denseRelation ->+      bench (caseLabel "csrTranspose/prebuilt var-degree" size) (nf denseTransposeWeight denseRelation),+    env (pure (forcedFrozenDigraphWith variableDegreeSuccessors size)) $ \denseRelation ->+      bench (caseLabel "frozenReachabilityFrom/prebuilt var-degree" size) (nf denseClosureWeight denseRelation),+    bench (caseLabel "world: containers IntSet reachability var-degree" size) (nf (containersReachabilityWith variableDegreeSuccessors) size),+    bench (caseLabel "hackage: containers Data.Graph build+reachable var-degree" size) (nf (hackageDataGraphBuildReachabilityWith variableDegreeSuccessors) size),+    env (pure (forcedHackageDataGraphWith variableDegreeSuccessors size)) $ \graph ->+      bench (caseLabel "hackage: containers Data.Graph reachable/prebuilt var-degree" size) (nf hackageDataGraphReachabilityWeight graph)+  ]++denseMonotoneSolverWeight :: Int -> Int+denseMonotoneSolverWeight size =+  either+    (const (-1))+    (Vector.sum . resultValues)+    (solveDenseMonotone intGrowthDeltaDomain size denseEvaluation (const 0))++denseEvaluation :: Int -> Evaluation Int Int+denseEvaluation key+  | key <= 0 =+      pure 1+  | otherwise =+      readEquationValue (EquationId (key - 1))++intGrowthDeltaDomain :: DeltaDomain Int Int+intGrowthDeltaDomain =+  DeltaDomain+    { deltaEmpty = 0,+      deltaNull = (== 0),+      deltaMerge = max,+      deltaApply = (+),+      deltaBetween = \oldValue newValue -> max 0 (newValue - oldValue)+    }++unionFindBuildWeight :: Int -> Int+unionFindBuildWeight =+  canonicalMapDigest . fst . UF.canonicalMapAndCompress . UF.fromClassIds . classIds++unionFindChainWeight :: [Int] -> Int+unionFindChainWeight ids =+  canonicalMapDigest (fst (UF.canonicalMapAndCompress (unionChain (fmap ClassId ids))))++unionFindCanonicalSweepWeight :: [Int] -> Int+unionFindCanonicalSweepWeight =+  canonicalMapDigest . fst . UF.canonicalMapAndCompress . UF.fromClassIds . fmap ClassId++balancedUnionFindCompressSizeWeight :: Int -> Int+balancedUnionFindCompressSizeWeight =+  canonicalMapDigest . fst . UF.canonicalMapAndCompress . balancedUnionFind++transactionBalancedUnionCompressWeight :: Int -> Int+transactionBalancedUnionCompressWeight size =+  transactionCanonicalDigest UF.emptyUnionFind $ \editor ->+    traverse_+      (\(leftClassId, rightClassId) -> UFT.transactionUnion editor leftClassId rightClassId)+      (balancedUnionPairs size)++transactionSparseOutlierWeight :: Int -> Int+transactionSparseOutlierWeight size =+  let ids = classIds size+      outlier = ClassId 1000000000+   in transactionCanonicalDigest UF.emptyUnionFind $ \editor -> do+        traverse_ (UFT.transactionInsertClassId editor) ids+        UFT.transactionInsertClassId editor outlier+        case ids of+          firstClassId : _ -> do+            _ <- UFT.transactionUnion editor outlier firstClassId+            pure ()+          [] ->+            pure ()++transactionColdFindSweepSizeWeight :: Int -> Int+transactionColdFindSweepSizeWeight size =+  transactionCanonicalDigest (balancedUnionFind size) $ \editor ->+    traverse_ (UFT.transactionFind editor) (classIds size)++transactionCanonicalDigest :: UF.UnionFind -> (forall state. UFT.UnionFindEditor state -> ST state ()) -> Int+transactionCanonicalDigest unionFind action =+  let (digest, _) =+        UFT.runUnionFindTransaction unionFind $ \editor -> do+          action editor+          canonicalParents <- UFT.transactionCanonicalMapAndCompress editor+          pure (canonicalMapDigest canonicalParents)+   in digest++canonicalMapDigest :: IntMap ClassId -> Int+canonicalMapDigest =+  IntMap.foldlWithKey'+    (\digest key classId -> digest * 16777619 + key * 31 + classIdKey classId)+    146959810++balancedColdFindSweepSizeWeight :: Int -> Int+balancedColdFindSweepSizeWeight size =+  unionFindFindSweepWeight size (balancedUnionFind size)++balancedCompressedFindSweepSizeWeight :: Int -> Int+balancedCompressedFindSweepSizeWeight size =+  unionFindFindSweepWeight size (snd (UF.canonicalMapAndCompress (balancedUnionFind size)))++unionFindFindSweepWeight :: Int -> UF.UnionFind -> Int+unionFindFindSweepWeight size unionFind =+  canonicalMapDigest (snd (foldl' findSweepStep (unionFind, IntMap.empty) (classIds size)))++findSweepStep :: (UF.UnionFind, IntMap ClassId) -> ClassId -> (UF.UnionFind, IntMap ClassId)+findSweepStep (unionFind, roots) classId =+  let (rootClassId, compressedUnionFind) = UF.find classId unionFind+   in (compressedUnionFind, IntMap.insert (classIdKey classId) rootClassId roots)++pairedUnionFindEquivalenceWeight :: Int -> Int+pairedUnionFindEquivalenceWeight size =+  let unionFind = pairedUnionFind size+   in length+        [ ()+        | (leftKey, rightKey) <- equivalenceQueryPairs size,+          UF.equivalent (ClassId leftKey) (ClassId rightKey) unionFind+        ]++containersUnionFindBalancedWeight :: Int -> Int+containersUnionFindBalancedWeight =+  containersParentDigest . containersCanonicalParents . containersBalancedUnionFind++hackageEquivalenceUnionFindWeight :: Int -> Int+hackageEquivalenceUnionFindWeight size =+  Equivalence.runEquivM' $ do+    traverse_ Equivalence.getClass (keys size)+    traverse_+      ( \(ClassId leftKey, ClassId rightKey) ->+          Equivalence.equate leftKey rightKey+      )+      (balancedUnionPairs size)+    equivalenceResults <-+      traverse+        (uncurry Equivalence.equivalent)+        (equivalenceQueryPairs size)+    pure (length (filter id equivalenceResults))++equivalenceQueryPairs :: Int -> [(Int, Int)]+equivalenceQueryPairs size =+  [ (leftKey, (leftKey + max 1 (size `div` 2)) `mod` max 1 size)+  | leftKey <- keys size+  ]++containersBalancedUnionFind :: Int -> ContainersUnionFind+containersBalancedUnionFind size =+  containersUnionPairsFrom (containersFromKeys (keys size)) (balancedUnionPairs size)++containersFromKeys :: [Int] -> ContainersUnionFind+containersFromKeys =+  ContainersUnionFind . IntMap.fromAscList . fmap (\key -> (key, key))++containersUnionPairsFrom :: ContainersUnionFind -> [(ClassId, ClassId)] -> ContainersUnionFind+containersUnionPairsFrom =+  foldl'+    ( \unionFind (ClassId leftKey, ClassId rightKey) ->+        containersUnion leftKey rightKey unionFind+    )++containersUnion :: Int -> Int -> ContainersUnionFind -> ContainersUnionFind+containersUnion leftKey rightKey unionFind@(ContainersUnionFind parents)+  | leftRoot == rightRoot = unionFind+  | otherwise = ContainersUnionFind (IntMap.insert rightRoot leftRoot parents)+  where+    leftRoot =+      containersFindRoot leftKey unionFind+    rightRoot =+      containersFindRoot rightKey unionFind++containersCanonicalParents :: ContainersUnionFind -> IntMap Int+containersCanonicalParents unionFind@(ContainersUnionFind parents) =+  IntMap.mapWithKey (\key _parent -> containersFindRoot key unionFind) parents++containersFindRoot :: Int -> ContainersUnionFind -> Int+containersFindRoot key (ContainersUnionFind parents) =+  case IntMap.lookup key parents of+    Just parentKey+      | parentKey /= key -> containersFindRoot parentKey (ContainersUnionFind parents)+    _ -> key++containersParentDigest :: IntMap Int -> Int+containersParentDigest =+  IntMap.foldlWithKey'+    (\digest key rootKey -> digest * 16777619 + key * 31 + rootKey)+    146959810++unionChain :: [ClassId] -> UF.UnionFind+unionChain ids =+  foldl'+    (\unionFind (leftClassId, rightClassId) -> UF.union leftClassId rightClassId unionFind)+    (UF.fromClassIds ids)+    (zip ids (drop 1 ids))++balancedUnionFind :: Int -> UF.UnionFind+balancedUnionFind =+  unionPairsFrom UF.emptyUnionFind . balancedUnionPairs++unionPairsFrom :: UF.UnionFind -> [(ClassId, ClassId)] -> UF.UnionFind+unionPairsFrom =+  foldl' (\unionFind (leftClassId, rightClassId) -> UF.union leftClassId rightClassId unionFind)++balancedUnionPairs :: Int -> [(ClassId, ClassId)]+balancedUnionPairs size =+  foldMap (balancedPairsForStride size) (takeWhile (< size) (iterate (* 2) 1))++balancedPairsForStride :: Int -> Int -> [(ClassId, ClassId)]+balancedPairsForStride size stride =+  fmap+    (\leftKey -> (ClassId leftKey, ClassId (leftKey + stride)))+    [0, 2 * stride .. size - stride - 1]++pairedUnionFind :: Int -> UF.UnionFind+pairedUnionFind size =+  unionPairsFrom (UF.fromClassIds (classIds size)) (pairedClassIds size)++pairedClassIds :: Int -> [(ClassId, ClassId)]+pairedClassIds size =+  fmap+    (\key -> (ClassId key, ClassId (key + 1)))+    [0, 2 .. size - 2]++closureWeight :: Int -> Int+closureWeight size =+  IntSet.size (closureUnderInt (successors size) (IntSet.singleton 0))++worklistWeight :: Int -> Int+worklistWeight size =+  IntSet.size+    ( traverseOnceIntSet+        (\visited item -> (IntSet.insert item visited, IntSet.difference (successors size item) visited))+        IntSet.empty+        (IntSet.singleton 0)+    )++denseClosureWeight :: ForcedFrozenDigraph -> Int+denseClosureWeight (ForcedFrozenDigraph relation) =+  IntSet.size (frozenReachabilityFrom relation (IntSet.singleton 0))++denseTransposeWeight :: ForcedFrozenDigraph -> Int+denseTransposeWeight (ForcedFrozenDigraph relation) =+  let transposed = csrTranspose (graphForward relation)+   in rnfCsr transposed `seq` csrVertexCount transposed++denseRepeatedClosureWeight :: ForcedFrozenDigraph -> Int+denseRepeatedClosureWeight (ForcedFrozenDigraph relation) =+  sum+    [ IntSet.size (frozenReachabilityFrom relation (IntSet.singleton rootKey))+    | rootKey <- repeatedQueryRoots (csrVertexCount (graphForward relation))+    ]++repeatedQueryRoots :: Int -> [Int]+repeatedQueryRoots size =+  [0, 4 .. size - 1]++denseBuildClosureWeight :: Int -> Int+denseBuildClosureWeight =+  denseBuildClosureWith successors++denseBuildClosureWith :: (Int -> Int -> IntSet) -> Int -> Int+denseBuildClosureWith successorsOf size =+  denseClosureWeight (forcedFrozenDigraphWith successorsOf size)++forcedFrozenDigraphForSize :: Int -> ForcedFrozenDigraph+forcedFrozenDigraphForSize =+  forcedFrozenDigraphWith successors++forcedFrozenDigraphWith :: (Int -> Int -> IntSet) -> Int -> ForcedFrozenDigraph+forcedFrozenDigraphWith successorsOf size =+  ForcedFrozenDigraph (frozenDigraphFromSuccessors size (successorsOf size))++denseCyclicBuildClosureWeight :: Int -> Int+denseCyclicBuildClosureWeight size =+  denseClosureWeight (forcedFrozenCyclicDigraphForSize size)++forcedFrozenCyclicDigraphForSize :: Int -> ForcedFrozenDigraph+forcedFrozenCyclicDigraphForSize size =+  ForcedFrozenDigraph (frozenDigraphFromSuccessors size (cyclicSuccessors size))++denseSccHeavyBuildClosureWeight :: Int -> Int+denseSccHeavyBuildClosureWeight size =+  denseClosureWeight (forcedFrozenSccHeavyDigraphForSize size)++forcedFrozenSccHeavyDigraphForSize :: Int -> ForcedFrozenDigraph+forcedFrozenSccHeavyDigraphForSize size =+  ForcedFrozenDigraph (frozenDigraphFromSuccessors size (sccHeavySuccessors size))++denseCachedClosureWeight :: ForcedFrozenDigraph -> Int+denseCachedClosureWeight (ForcedFrozenDigraph relation) =+  let seeds = IntSet.singleton 0+      coldCache = sccClosureCacheFor relation+      (coldReachable, warmedCache) =+        frozenReachabilityWithCache coldCache seeds+      (hotReachable, _hotCache) =+        frozenReachabilityWithCache warmedCache seeds+   in IntSet.size coldReachable + IntSet.size hotReachable++hotSingletonCache :: Int -> ForcedSccClosureCache+hotSingletonCache size =+  let coldCache =+        sccClosureCacheFor (frozenDigraphFromSuccessors size (const IntSet.empty))+      seeds =+        IntSet.singleton 0+      (_firstReachable, onceQueriedCache) =+        frozenReachabilityWithCache coldCache seeds+      (secondReachable, hotCache) =+        frozenReachabilityWithCache onceQueriedCache seeds+   in ForcedSccClosureCache+        { forcedCacheReceipt = IntSet.size secondReachable,+          forcedCache = hotCache+        }++hotSingletonCacheWeight :: ForcedSccClosureCache -> Int+hotSingletonCacheWeight cache =+  IntSet.size (fst (frozenReachabilityWithCache (forcedCache cache) (IntSet.singleton 0)))++graphSnapshotOverlayReachabilityWeight :: Int -> Int+graphSnapshotOverlayReachabilityWeight size =+  IntSet.size (snapshotReachabilityFrom snapshot (IntSet.singleton 0))+  where+    snapshot =+      insertSnapshotEdge+        (Edge (max 0 (size - 1)) 0)+        (snapshotFromFrozen (frozenDigraphFromSuccessors size (successors size)))++rnfFrozenDigraph :: FrozenDigraph -> ()+rnfFrozenDigraph graph =+  rnfCsr (graphForward graph)+    `seq` rnfCsr (graphBackward graph)+    `seq` rnfSccPlan (graphSccPlan graph)++rnfSccPlan :: SccPlan -> ()+rnfSccPlan plan =+  rnf (sccOfVertex plan)+    `seq` rnfCsr (sccMembers plan)+    `seq` rnfCsr (condensation plan)+    `seq` rnfCsr (condensationBackward plan)++rnfCsr :: Csr shape -> ()+rnfCsr csr =+  rnf (csrVertexCount csr, csrOffsets csr, csrTargets csr)++boundedFixpointWeight :: Int -> Either Int Int+boundedFixpointWeight size =+  case fixpointBounded (fromIntegral size) decrementToZero size of+    Left divergence -> Left (showLength (show divergence))+    Right result -> Right result++containersReachabilityWeight :: Int -> Int+containersReachabilityWeight =+  containersReachabilityWith successors++containersReachabilityWith :: (Int -> Int -> IntSet) -> Int -> Int+containersReachabilityWith successorsOf size =+  IntSet.size (containersReachability (successorsOf size) (IntSet.singleton 0))++hackageDataGraphBuildReachabilityWeight :: Int -> Int+hackageDataGraphBuildReachabilityWeight =+  hackageDataGraphBuildReachabilityWith successors++hackageDataGraphBuildReachabilityWith :: (Int -> Int -> IntSet) -> Int -> Int+hackageDataGraphBuildReachabilityWith successorsOf =+  hackageDataGraphReachabilityWeight . forcedHackageDataGraphWith successorsOf++hackageDataGraphReachabilityWeight :: ForcedGraph -> Int+hackageDataGraphReachabilityWeight (ForcedGraph graph) =+  length (Graph.reachable graph 0)++forcedHackageDataGraphForSize :: Int -> ForcedGraph+forcedHackageDataGraphForSize =+  forcedHackageDataGraphWith successors++forcedHackageDataGraphWith :: (Int -> Int -> IntSet) -> Int -> ForcedGraph+forcedHackageDataGraphWith successorsOf size =+  ForcedGraph+    ( Graph.buildG+        (0, max 0 (size - 1))+        [ (key, target)+        | key <- keys size,+          target <- IntSet.toAscList (successorsOf size key)+        ]+    )++containersReachability :: (Int -> IntSet) -> IntSet -> IntSet+containersReachability nextItems =+  containersReachabilityStep nextItems IntSet.empty++containersReachabilityStep :: (Int -> IntSet) -> IntSet -> IntSet -> IntSet+containersReachabilityStep nextItems visited pending =+  case IntSet.minView pending of+    Nothing -> visited+    Just (item, remainingPending)+      | IntSet.member item visited ->+          containersReachabilityStep nextItems visited remainingPending+      | otherwise ->+          let nextPending =+                IntSet.union+                  remainingPending+                  (IntSet.difference (nextItems item) visited)+           in containersReachabilityStep nextItems (IntSet.insert item visited) nextPending++decrementToZero :: Int -> Int+decrementToZero value+  | value <= 0 = 0+  | otherwise = value - 1++successors :: Int -> Int -> IntSet+successors size key =+  IntSet.fromAscList+    (filter (< size) [key + 1, key + 2])++variableDegreeSuccessors :: Int -> Int -> IntSet+variableDegreeSuccessors size key+  | size <= 0 = IntSet.empty+  | otherwise =+      IntSet.fromList+        (filter (< size) [key + step | step <- [1 .. 1 + (key `mod` 6)]])++sccHeavySuccessors :: Int -> Int -> IntSet+sccHeavySuccessors size key+  | size <= 0 = IntSet.empty+  | otherwise =+      IntSet.fromList+        [ (key + 1) `mod` size,+          (key + 2) `mod` size,+          (key - 1) `mod` size+        ]++cyclicSuccessors :: Int -> Int -> IntSet+cyclicSuccessors size key+  | size <= 0 = IntSet.empty+  | otherwise = IntSet.fromList [(key + 1) `mod` size, (key + 2) `mod` size]++classIds :: Int -> [ClassId]+classIds size =+  fmap ClassId (keys size)++holeyKeys :: Int -> [Int]+holeyKeys =+  fmap (* 2) . keys++negativeKeys :: Int -> [Int]+negativeKeys =+  fmap negate . keys++densePrefixWithGiantOutlier :: Int -> [Int]+densePrefixWithGiantOutlier size =+  keys size <> [1_000_000_000]++mixedDenseSparseKeys :: Int -> [Int]+mixedDenseSparseKeys size =+  keys size <> fmap (+ 1_000_000_000) (sampleKeys size)
+ bench/support/BenchSupport.hs view
@@ -0,0 +1,44 @@+module BenchSupport+  ( foundationSizes,+    numericSizes,+    syntaxSizes,+    termSizes,+    unionFindSizes,+    caseLabel,+    keys,+    sampleKeys,+    showLength,+  )+where++import Prelude++foundationSizes :: [Int]+foundationSizes = [128, 512, 2048]++numericSizes :: [Int]+numericSizes = [256, 1024, 4096]++syntaxSizes :: [Int]+syntaxSizes = [16, 32, 64]++termSizes :: [Int]+termSizes = [128, 512, 1024]++unionFindSizes :: [Int]+unionFindSizes = [128, 512, 2048, 8192]++caseLabel :: String -> Int -> String+caseLabel label size =+  label <> " n=" <> show size++keys :: Int -> [Int]+keys size = [0 .. size - 1]++sampleKeys :: Int -> [Int]+sampleKeys size =+  take 64 (keys size)++showLength :: String -> Int+showLength =+  length
+ bench/syntax/Main.hs view
@@ -0,0 +1,11 @@+module Main+  ( main,+  )+where++import SyntaxBench (syntaxBenchmarks)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [syntaxBenchmarks]
+ bench/syntax/SyntaxBench.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE DeriveTraversable #-}++module SyntaxBench+  ( syntaxBenchmarks,+  )+where++import Data.IntMap.Strict+  ( IntMap,+  )+import Data.IntMap.Strict qualified as IntMap+import Data.Set qualified as Set+import BenchSupport+  ( caseLabel,+    keys,+    syntaxSizes,+  )+import Moonlight.Core (ClassId (..))+import Moonlight.Core qualified as EGraph+import Moonlight.Core+  ( zipSameNodeShape,+  )+import Moonlight.Core+  ( Pattern (..),+    patternVariables,+  )+import Moonlight.Core+  ( Substitution (..),+    emptySubstitution,+    insertSubst,+    mergeSubstitutions,+  )+import Moonlight.Core+  ( StructuralLaw (..),+    TheorySpec (..),+    commutativeBinary,+    expandPatternByTheory,+  )+import Test.Tasty.Bench+  ( Benchmark,+    bench,+    bgroup,+    nf,+  )+import Prelude++data BenchNode a+  = BenchLeaf !Int+  | BenchUnary !a+  | BenchBinary !a !a+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)++syntaxBenchmarks :: Benchmark+syntaxBenchmarks =+  bgroup+    "syntax"+    (syntaxSizes >>= syntaxBenchmarksForSize)++syntaxBenchmarksForSize :: Int -> [Benchmark]+syntaxBenchmarksForSize size =+  [ bench (caseLabel "pattern variables" size) (nf patternVariableWeight size),+    bench (caseLabel "commutative expansion" size) (nf theoryExpansionWeight size),+    bench (caseLabel "substitution incremental merge" size) (nf substitutionMergeWeight size),+    bench (caseLabel "substitution pair merge" size) (nf substitutionPairMergeWeight size),+    bench (caseLabel "hackage: containers IntMap checked union" size) (nf hackageContainersCheckedUnionWeight size),+    bench (caseLabel "same-shape zip" size) (nf shapeZipWeight size)+  ]++patternVariableWeight :: Int -> Int+patternVariableWeight =+  Set.size . patternVariables . benchPattern++theoryExpansionWeight :: Int -> Int+theoryExpansionWeight =+  sum . fmap (length . expandPatternByTheory commutativeTheory . binaryPatternForKey) . keys++substitutionMergeWeight :: Int -> Int+substitutionMergeWeight size =+  case foldl' mergeStep (Just emptySubstitution) (keys size) of+    Nothing -> 0+    Just substitution -> substitutionSize substitution++substitutionPairMergeWeight :: Int -> Int+substitutionPairMergeWeight size =+  case mergeSubstitutions (benchSubstitution size) (benchSubstitution size) of+    Nothing -> 0+    Just substitution -> substitutionSize substitution++hackageContainersCheckedUnionWeight :: Int -> Int+hackageContainersCheckedUnionWeight size =+  maybe 0 IntMap.size (checkedIntMapUnion (benchSubstitutionMap size) (benchSubstitutionMap size))++checkedIntMapUnion :: IntMap ClassId -> IntMap ClassId -> Maybe (IntMap ClassId)+checkedIntMapUnion left right =+  if IntMap.null conflicts+    then Just (IntMap.union left right)+    else Nothing+  where+    conflicts =+      IntMap.filter (uncurry (/=)) (IntMap.intersectionWith (,) left right)++shapeZipWeight :: Int -> Int+shapeZipWeight size =+  case zipSameNodeShape (benchNode size) (benchNode (size + 1)) of+    Nothing -> 0+    Just zipped -> length zipped++benchPattern :: Int -> Pattern BenchNode+benchPattern size =+  foldr+    (\key rest -> PatternNode (BenchBinary (PatternVar (EGraph.mkPatternVar key)) rest))+    (PatternNode (BenchLeaf 0))+    (keys size)++binaryPatternForKey :: Int -> Pattern BenchNode+binaryPatternForKey key =+  PatternNode+    ( BenchBinary+        (PatternVar (EGraph.mkPatternVar key))+        (PatternNode (BenchLeaf key))+    )++benchNode :: Int -> BenchNode Int+benchNode size =+  BenchBinary (size + 1) (size + 2)++commutativeTheory :: TheorySpec BenchNode+commutativeTheory =+  TheorySpec {tsClassify = classify}+  where+    classify node =+      case node of+        BenchBinary _left _right -> commutativeBinary BenchBinary+        _ -> Ordinary++    classify :: BenchNode value -> StructuralLaw BenchNode value++mergeStep :: Maybe Substitution -> Int -> Maybe Substitution+mergeStep maybeSubstitution key =+  maybeSubstitution >>= \substitution ->+    mergeSubstitutions substitution (insertSubst (EGraph.mkPatternVar key) (ClassId key) emptySubstitution)++benchSubstitution :: Int -> Substitution+benchSubstitution =+  Substitution . benchSubstitutionMap++benchSubstitutionMap :: Int -> IntMap ClassId+benchSubstitutionMap size =+  IntMap.fromAscList+    [ (key, ClassId key)+    | key <- keys size+    ]++substitutionSize :: Substitution -> Int+substitutionSize (Substitution entries) =+  IntMap.size entries
+ bench/term/Main.hs view
@@ -0,0 +1,11 @@+module Main+  ( main,+  )+where++import TermBench (termBenchmarks)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [termBenchmarks]
+ bench/term/TermBench.hs view
@@ -0,0 +1,409 @@+{-# LANGUAGE DeriveTraversable #-}++module TermBench+  ( termBenchmarks,+  )+where++import Data.Bifunctor (first)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Vector.Unboxed qualified as U+import BenchSupport+  ( caseLabel,+    keys,+    termSizes,+  )+import Moonlight.Core+  ( Column (..),+    Pattern (..),+    PatternFreeJoinPlan (..),+    RelationStats (..),+    ArrangementKey,+    Database,+    TermCommand (..),+    arrangementKeyForOperator,+    arrangementPrefixForKey,+    canonicalizeDirtyRows,+    compact,+    commitTermCommands,+    relationStats,+    committedDatabase,+    compilePatternFreeJoinPlan,+    arrangementRowsForPrefix,+    deleteTuple,+    freeJoin,+    rowsDeleted,+    rowsInserted,+    operatorRows,+    resultKeysUsingAnyChildKey,+    emptyDatabase,+    extractOperator,+    insertTuple,+    insertTuples,+    lookupLeastTuple,+    mkPatternVar,+  )+import Test.Tasty.Bench+  ( Benchmark,+    bench,+    bgroup,+    env,+    nf,+  )+import Prelude++data TestTerm key+  = TNull+  | TUnary !key+  | TBinary !key !key+  | TNary [key]+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)++type BenchDatabase = Database TestTerm Int++termBenchmarks :: Benchmark+termBenchmarks =+  bgroup+    "term"+    [ termTupleSetBenchmarks,+      termDatabaseBenchmarks+    ]++termTupleSetBenchmarks :: Benchmark+termTupleSetBenchmarks =+  bgroup+    "term-tuple-set"+    (termSizes >>= termTupleSetBenchmarksForSize)++termTupleSetBenchmarksForSize :: Int -> [Benchmark]+termTupleSetBenchmarksForSize size =+  [ bench (caseLabel "containers Set tuple populate/extract" size) (nf tupleSetBuildExtractWeight size),+    env (pure (tupleSetPair size)) $ \tuples ->+      bench (caseLabel "containers Set tuple merge/extract" size) (nf tupleSetMergeWeight tuples)+  ]++termDatabaseBenchmarks :: Benchmark+termDatabaseBenchmarks =+  bgroup+    "term-database"+    (termSizes >>= termDatabaseBenchmarksForSize)++termDatabaseBenchmarksForSize :: Int -> [Benchmark]+termDatabaseBenchmarksForSize size =+  [ bench (caseLabel "insert/build row-count" size) (nf databaseBuildWeight size),+    bench (caseLabel "bulk insert/build row-count" size) (nf databaseBulkBuildWeight size),+    prebuiltDatabaseLookupBenchmark size,+    bench (caseLabel "insert/lookup" size) (nf databaseBuildLookupWeight size),+    bench (caseLabel "alternating insert/query" size) (nf databaseAlternatingInsertLookupWeight size),+    bench (caseLabel "bulk insert/lookup" size) (nf databaseBulkBuildLookupWeight size),+    bench (caseLabel "command batch insert/lookup" size) (nf databaseCommandBatchBuildLookupWeight size),+    bench (caseLabel "child-user reverse lookup" size) (nf databaseChildUserLookupWeight size),+    bench (caseLabel "arrangement prefix materialization" size) (nf databaseArrangementPrefixLookupWeight size),+    bench (caseLabel "free join two-atom" size) (nf databasePatternFreeJoinWeight size),+    bench (caseLabel "canonicalize dirty rows" size) (nf databaseCanonicalizeDirtyRowsWeight size),+    bench (caseLabel "delete half+compact row-count" size) (nf databaseDeleteCompactWeight size),+    bench (caseLabel "delete indexed+unindexed rows" size) (nf databaseIndexedUnindexedDeleteWeight size),+    bench (caseLabel "relation stats result/child prefixes" size) (nf databaseRelationStatsWeight size),+    bench (caseLabel "hackage: containers Map term insert/lookup" size) (nf hackageContainersTermMapLookupWeight size),+    bench (caseLabel "hackage: containers Map term->IntSet insert/lookup" size) (nf hackageContainersTermMultiMapLookupWeight size),+    env (pure (keys size)) $ \lookupKeys ->+      bench (caseLabel "build/lookup sweep" size) (nf databaseBuildLookupKeysWeight lookupKeys)+  ]++tupleSetBuildExtractWeight :: Int -> Int+tupleSetBuildExtractWeight =+  length . Set.toAscList . Set.fromList . tupleSetTuples++tupleSetMergeWeight :: ([[Int]], [[Int]]) -> Int+tupleSetMergeWeight (leftTuples, rightTuples) =+  length (Set.toAscList (Set.union (Set.fromList leftTuples) (Set.fromList rightTuples)))++tupleSetPair :: Int -> ([[Int]], [[Int]])+tupleSetPair size =+  (tupleSetTuples size, shiftedTupleSetTuples size)++tupleSetTuples :: Int -> [[Int]]+tupleSetTuples size =+  fmap (\key -> [key, key + 1, key + 2]) (keys size)++shiftedTupleSetTuples :: Int -> [[Int]]+shiftedTupleSetTuples size =+  fmap (\key -> [key, key + 2, key + 4]) (keys size)++databaseBuildLookupWeight :: Int -> Int+databaseBuildLookupWeight size =+  databaseLookupWeight size (databaseForSize size)++databaseBuildWeight :: Int -> Int+databaseBuildWeight =+  databaseRowCount . databaseForSize++databaseAlternatingInsertLookupWeight :: Int -> Int+databaseAlternatingInsertLookupWeight size =+  snd $+    foldl'+      insertAndQuery+      (emptyDatabase, 0)+      (keys size)+  where+    insertAndQuery (database, checksum) key =+      ( insertedDatabase,+        checksum + maybe 0 id (lookupLeastTuple (termForKey key) insertedDatabase)+      )+      where+        insertedDatabase =+          insertTuple key (termForKey key) database++databaseBulkBuildLookupWeight :: Int -> Int+databaseBulkBuildLookupWeight size =+  databaseLookupWeight size (bulkDatabaseForSize size)++databaseBulkBuildWeight :: Int -> Int+databaseBulkBuildWeight =+  databaseRowCount . bulkDatabaseForSize++databaseCommandBatchBuildLookupWeight :: Int -> Int+databaseCommandBatchBuildLookupWeight size =+  databaseLookupWeight size (databaseCommandBatchForSize size)++prebuiltDatabaseLookupBenchmark :: Int -> Benchmark+prebuiltDatabaseLookupBenchmark size =+  databaseRowCount database `seq`+    bench (caseLabel "lookup/prebuilt" size) (nf (databaseLookupKeysWeight lookupKeys) database)+  where+    database =+      databaseForSize size+    lookupKeys =+      keys size++hackageContainersTermMapLookupWeight :: Int -> Int+hackageContainersTermMapLookupWeight size =+  sum+    [ maybe 0 id (Map.lookup (termForKey key) table)+    | key <- keys size+    ]+  where+    table =+      Map.fromList+        [ (termForKey key, key)+        | key <- keys size+        ]++hackageContainersTermMultiMapLookupWeight :: Int -> Int+hackageContainersTermMultiMapLookupWeight size =+  sum+    [ maybe 0 leastIntSetValue (Map.lookup (termForKey key) table)+    | key <- keys size+    ]+  where+    table =+      Map.fromListWith+        IntSet.union+        [ (termForKey key, IntSet.singleton key)+        | key <- keys size+        ]++databaseBuildLookupKeysWeight :: [Int] -> Int+databaseBuildLookupKeysWeight lookupKeys =+  databaseLookupKeysWeight lookupKeys (databaseForSize (length lookupKeys))++databaseLookupWeight :: Int -> BenchDatabase -> Int+databaseLookupWeight size database =+  databaseLookupKeysWeight (keys size) database++databaseLookupKeysWeight :: [Int] -> BenchDatabase -> Int+databaseLookupKeysWeight lookupKeys database =+  sum+    [ maybe 0 id (lookupLeastTuple (termForKey key) database)+    | key <- lookupKeys+    ]++databaseChildUserLookupWeight :: Int -> Int+databaseChildUserLookupWeight size =+  IntSet.size (resultKeysUsingAnyChildKey (IntSet.fromList (sampleChildKeys size)) (databaseForSize size))++databaseArrangementPrefixLookupWeight :: Int -> Either String Int+databaseArrangementPrefixLookupWeight size =+  first show $ do+    let operator =+          extractOperator (TBinary () ())+    arrangementKey <-+      arrangementKeyForOperator operator [ChildColumn 0]+    arrangementPrefix <-+      arrangementPrefixForKey arrangementKey [size + 1]+    (rows, arrangedDatabase) <-+      arrangementRowsForPrefix operator arrangementKey arrangementPrefix (databaseForSize size)+    pure (length rows + databaseRowCount arrangedDatabase)++databasePatternFreeJoinWeight :: Int -> Either String Int+databasePatternFreeJoinWeight size =+  first show $ do+    (bindings, _database) <-+      freeJoin plan (databaseForSize size)+    pure (length bindings + length roots)+  where+    PatternFreeJoinPlan+      { patternFreeJoinPlan = plan,+        patternFreeJoinRoots = roots+      } =+        compileBinaryPatternFreeJoinPlan+++databaseCanonicalizeDirtyRowsWeight :: Int -> Int+databaseCanonicalizeDirtyRowsWeight size =+  databaseRowCount canonicalDatabase + length commands + insertedCount - deletedCount+  where+    dirtyKeys =+      IntSet.fromList (sampleChildKeys size)+    delta =+      canonicalizeDirtyRows dirtyKeys id (databaseForSize size)+    (rowDelta, commands, canonicalDatabase) =+      delta+    insertedCount =+      sum (fmap length (Map.elems (rowsInserted rowDelta)))+    deletedCount =+      sum (fmap length (Map.elems (rowsDeleted rowDelta)))++databaseDeleteCompactWeight :: Int -> Int+databaseDeleteCompactWeight size =+  databaseRowCount compactedDatabase+    + databaseLookupWeight size compactedDatabase+  where+    compactedDatabase =+      compact (deleteHalfDatabaseForSize size)++deleteHalfDatabaseForSize :: Int -> BenchDatabase+deleteHalfDatabaseForSize size =+  foldl'+    (\database key -> deleteTuple key (termForKey key) database)+    (databaseForSize size)+    (filter even (keys size))++databaseIndexedUnindexedDeleteWeight :: Int -> Either String Int+databaseIndexedUnindexedDeleteWeight size = do+  arrangementKey <-+    first show (arrangementKeyForOperator binaryOperator [ResultColumn])+  emptyPrefix <-+    first show (arrangementPrefixForKey arrangementKey [])+  (_indexedRows, indexedDatabase) <-+    first show $+      arrangementRowsForPrefix+        binaryOperator+        arrangementKey+        emptyPrefix+        firstBurstDatabase+  let completedDatabase =+        foldl'+          (\database key -> insertTuple key (termForKey key) database)+          indexedDatabase+          secondBurstKeys+      deletedDatabase =+        foldl'+          (\database key -> deleteTuple key (termForKey key) database)+          completedDatabase+          boundaryDeleteKeys+  pure (databaseRowCount deletedDatabase + databaseLookupWeight size deletedDatabase)+  where+    allKeys =+      keys size+    (firstBurstKeys, secondBurstKeys) =+      splitAt (size `div` 2) allKeys+    firstBurstDatabase =+      foldl'+        (\database key -> insertTuple key (termForKey key) database)+        emptyDatabase+        firstBurstKeys+    boundaryDeleteKeys =+      take 1 (filter isBinaryKey firstBurstKeys)+        <> take 1 (filter isBinaryKey secondBurstKeys)+    isBinaryKey :: Int -> Bool+    isBinaryKey key =+      key `mod` 4 == 2+    binaryOperator =+      extractOperator (TBinary () ())++databaseRelationStatsWeight :: Int -> Either String Int+databaseRelationStatsWeight size = do+  arrangementKeys <-+    relationStatsArrangementKeys+  stats <-+    first show $+      relationStats+        arrangementKeys+        (extractOperator (TBinary () ()))+        (databaseForSize size)+  pure (maybe 0 relationStatsWeight stats)++relationStatsArrangementKeys :: Either String [ArrangementKey]+relationStatsArrangementKeys =+  first show $+    traverse+      (arrangementKeyForOperator (extractOperator (TBinary () ())))+      [ [ResultColumn],+        [ChildColumn 0],+        [ChildColumn 1],+        [ResultColumn, ChildColumn 0],+        [ChildColumn 0, ChildColumn 1]+      ]++relationStatsWeight :: RelationStats -> Int+relationStatsWeight stats =+  rowCount stats+    + liveRowCount stats+    + U.sum (distinctPerColumn stats)+    + sum (Map.elems (distinctPerPrefix stats))+    + maximumBucketSize stats++compileBinaryPatternFreeJoinPlan :: PatternFreeJoinPlan TestTerm Int+compileBinaryPatternFreeJoinPlan =+  compilePatternFreeJoinPlan+    ( PatternNode+        ( TBinary+            (PatternVar (mkPatternVar 0))+            (PatternVar (mkPatternVar 1))+        )+    )++sampleChildKeys :: Int -> [Int]+sampleChildKeys size =+  fmap (+ 1) (keys size)++databaseForSize :: Int -> BenchDatabase+databaseForSize size =+  foldl'+    (\database key -> insertTuple key (termForKey key) database)+    emptyDatabase+    (keys size)++bulkDatabaseForSize :: Int -> BenchDatabase+bulkDatabaseForSize size =+  insertTuples+    (fmap (\key -> (key, termForKey key)) (keys size))+    emptyDatabase++databaseCommandBatchForSize :: Int -> BenchDatabase+databaseCommandBatchForSize size =+  committedDatabase (commitTermCommands commands emptyDatabase)+  where+    commands =+      fmap (\key -> InsertTerm key (termForKey key)) (keys size)++databaseRowCount :: BenchDatabase -> Int+databaseRowCount =+  sum . fmap length . Map.elems . operatorRows++termForKey :: Int -> TestTerm Int+termForKey key =+  case key `mod` 4 of+    0 -> TNull+    1 -> TUnary (key + 1)+    2 -> TBinary (key + 1) (key + 2)+    _ -> TNary [key + 1, key + 2, key + 3]+++leastIntSetValue :: IntSet -> Int+leastIntSetValue =+  maybe 0 id . IntSet.lookupMin
+ moonlight-core.cabal view
@@ -0,0 +1,540 @@+cabal-version:       3.0+name:                moonlight-core+version:             0.1.0.0+synopsis:            Mathematical basis for Pale Meridian.+description:         A total vocabulary of numeric classes, structural identity, orders, patterns, fixpoints, union-find, finite registries, and host-neutral e-graph programs.+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-core++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-core-basis+  import: shared-properties+  visibility: private+  hs-source-dirs: src-basis+  exposed-modules:+    Moonlight.Core.Aggregate+    Moonlight.Core.Boundary+    Moonlight.Core.Cardinality+    Moonlight.Core.Capability+    Moonlight.Core.Dedup+    Moonlight.Core.DenseKey+    Moonlight.Core.DomainId+    Moonlight.Core.DomainId.Internal+    Moonlight.Core.Error+    Moonlight.Core.Finite+    Moonlight.Core.Hash+    Moonlight.Core.Identifier+    Moonlight.Core.Identifier.EGraph+    Moonlight.Core.IsoNorm+    Moonlight.Core.LawName+    Moonlight.Core.MapAccum+    Moonlight.Core.MapInvert+    Moonlight.Core.Match+    Moonlight.Core.ModuleIdentifier+    Moonlight.Core.OrdCollection+    Moonlight.Core.Order+    Moonlight.Core.ProofManifest+    Moonlight.Core.Queue+    Moonlight.Core.Refinement+    Moonlight.Core.Relational+    Moonlight.Core.Scan+    Moonlight.Core.StableHash+    Moonlight.Core.TotalRegistry+    Moonlight.Core.TypeLevel+    Moonlight.Core.Validation+    Moonlight.Internal.Unsound+  build-depends:+    base >= 4.22 && < 5+    , bytestring >= 0.11 && < 0.13+    , containers >= 0.8 && < 0.9+    , memory >= 0.18 && < 0.19+    , text >= 2.0 && < 2.2++library moonlight-core-egraph-program+  import: shared-properties+  visibility: public+  hs-source-dirs: src-egraph-program+  exposed-modules:+    Moonlight.Core.EGraph.Program+  build-depends:+    base >= 4.22 && < 5+    , free >= 5.2 && < 6+    , moonlight-core:moonlight-core-basis++library moonlight-core-numeric+  import: shared-properties+  visibility: private+  hs-source-dirs: src-numeric+  exposed-modules:+    Moonlight.Core.ApproxEq+    Moonlight.Core.Canon+    Moonlight.Core.CanonicalNumber+    Moonlight.Core.ExactToken+    Moonlight.Core.Niche+    Moonlight.Core.Numeric+    Moonlight.Core.Scalar+    Moonlight.Core.Unsound+  other-modules:+    Moonlight.Core.CanonicalNumber.Internal+    Moonlight.Core.Niche.Internal+    Moonlight.Internal.FloatMath+  build-depends:+    base >= 4.22 && < 5+    , bytestring >= 0.11 && < 0.13+    , containers >= 0.8 && < 0.9+    , moonlight-core:moonlight-core-basis+    , text >= 2.0 && < 2.2++library moonlight-core-syntax+  import: shared-properties+  visibility: public+  hs-source-dirs: src-syntax+  exposed-modules:+    Moonlight.Core.Guidance+    Moonlight.Core.Language+    Moonlight.Core.Pattern+    Moonlight.Core.Pattern.AntiUnify+    Moonlight.Core.Fix.Order+    Moonlight.Core.Site.Program+    Moonlight.Core.Substitution+    Moonlight.Core.Theory+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.8 && < 0.9+    , data-fix >= 0.3 && < 0.4+    , moonlight-core:moonlight-core-basis+    , transformers >= 0.6 && < 1++library moonlight-core-automata+  import: shared-properties+  visibility: public+  hs-source-dirs: src-automata+  default-extensions:+    NoStrictData+  exposed-modules:+    Moonlight.Automata.Pure.Algebra+    Moonlight.Automata.Pure.Coalgebra+    Moonlight.Automata.Pure.Core+    Moonlight.Automata.Pure.Transducer+    Moonlight.Core.Pattern.Automata+    Moonlight.Core.Pattern.Kernel+  build-depends:+    base >= 4.22 && < 5+    , comonad >= 5 && < 6+    , containers >= 0.8 && < 0.9+    , data-fix >= 0.3 && < 0.4+    , free >= 5.2 && < 6+    , moonlight-core:moonlight-core-basis+    , moonlight-core:moonlight-core-syntax+    , recursion-schemes >= 5.2 && < 6+    , these >= 1.2 && < 1.3+    , transformers >= 0.6 && < 1++library moonlight-core-solver+  import: shared-properties+  visibility: private+  hs-source-dirs: src-solver+  exposed-modules:+    Moonlight.Core.Fixpoint+    Moonlight.Core.Fixpoint.Dense+    Moonlight.Core.UnionFind+    Moonlight.Core.UnionFind.Transaction+  other-modules:+    Moonlight.Core.Fixpoint.Internal.Combinators+    Moonlight.Core.Fixpoint.Internal.Solver.Types+    Moonlight.Core.Fixpoint.Internal.Solver.Plan+    Moonlight.Core.Fixpoint.Internal.Solver.BitSet+    Moonlight.Core.Fixpoint.Internal.Solver.WorkQueue+    Moonlight.Core.Fixpoint.Internal.Solver.Arena+    Moonlight.Core.Fixpoint.Internal.Solver.Engine+    Moonlight.Core.Fixpoint.Dense.Internal.Csr+    Moonlight.Core.Fixpoint.Dense.Internal.Policy+    Moonlight.Core.Fixpoint.Dense.Internal.AdaptiveIntSet+    Moonlight.Core.Fixpoint.Dense.Internal.Scc+    Moonlight.Core.Fixpoint.Dense.Internal.ClosureCache+    Moonlight.Core.Fixpoint.Dense.Internal.Snapshot+    Moonlight.Core.Fixpoint.Dense.Internal.Scratch+    Moonlight.Core.Fixpoint.Dense.Internal.Traverse+    Moonlight.Core.UnionFind.Transaction.Internal.Types+    Moonlight.Core.UnionFind.Transaction.Internal.Policy+    Moonlight.Core.UnionFind.Transaction.Internal.DenseStore+    Moonlight.Core.UnionFind.Transaction.Internal.Storage+    Moonlight.Core.UnionFind.Transaction.Internal.Algorithm+    Moonlight.Core.UnionFind.Transaction.Internal.Snapshot+    Moonlight.Core.UnionFind.Transaction.Internal.Lifecycle+    Moonlight.Core.UnionFind.Internal.Semantics+    Moonlight.Core.UnionFind.Internal.Types+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.8 && < 0.9+    , deepseq >= 1.4 && < 1.6+    , free >= 5.2 && < 6+    , moonlight-core:moonlight-core-basis+    , primitive >= 0.7 && < 0.10+    , vector >= 0.13 && < 0.14++library moonlight-core-term+  import: shared-properties+  visibility: private+  hs-source-dirs: src-term+  exposed-modules:+    Moonlight.Core.Term.Database+    Moonlight.Core.Term.Database.Canonicalize+  other-modules:+    Moonlight.Core.Term.Database.Arrangement+    Moonlight.Core.Term.Database.Atom+    Moonlight.Core.Term.Database.Command+    Moonlight.Core.Term.Database.Encode+    Moonlight.Core.Term.Database.FreeJoin+    Moonlight.Core.Term.Database.Index+    Moonlight.Core.Term.Database.Lookup+    Moonlight.Core.Term.Database.OperatorTable+    Moonlight.Core.Term.Database.Pattern+    Moonlight.Core.Term.Database.Projection+    Moonlight.Core.Term.Database.Table+    Moonlight.Core.Term.Database.Transaction+    Moonlight.Core.Term.Database.Types+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.8 && < 0.9+    , moonlight-core:moonlight-core-basis+    , moonlight-core:moonlight-core-syntax+    , primitive >= 0.7 && < 0.10+    , vector >= 0.13 && < 0.14++library+  import: shared-properties+  hs-source-dirs: src-public+  exposed-modules:+    Moonlight.Core+  reexported-modules:+    Moonlight.Core.Unsound+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.8 && < 0.9+    , moonlight-core:moonlight-core-egraph-program+    , moonlight-core:moonlight-core-numeric+    , moonlight-core:moonlight-core-solver+    , moonlight-core:moonlight-core-basis+    , moonlight-core:moonlight-core-syntax+    , moonlight-core:moonlight-core-term++common moonlight-core-test-properties+  default-language: GHC2024+  ghc-options: -Wall -Wcompat+  default-extensions:+    TypeFamilies+  build-depends:+    base >= 4.22 && < 5+    , bytestring >= 0.11+    , containers >= 0.8+    , filepath >= 1.4+    , moonlight-core+    , primitive >= 0.7+    , text >= 2.0+    , tasty >= 1.4+    , tasty-hunit >= 0.10+    , tasty-quickcheck >= 0.10+    , QuickCheck >= 2.14+    , vector >= 0.13++test-suite moonlight-core-basis-test+  import: moonlight-core-test-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    test/basis+    test/support+  main-is: Main.hs+  other-modules:+    BasisTests+    BoundarySpec+    CardinalitySpec+    DenseKeySpec+    FiniteSpec+    IsoNormSpec+    LawProperty+    MapAccumSpec+    OrdCollectionSpec+    OrderSpec+    ProofManifestSpec+    QueueSpec+    RelationalSpec+    SourceShape+    StableHashSpec+    TotalRegistrySpec+    TypeLevelSpec+    ValidationSpec++test-suite moonlight-core-numeric-test+  import: moonlight-core-test-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    test/numeric+    test/support+  main-is: Main.hs+  other-modules:+    ApproxEqSpec+    CanonSpec+    CanonicalNumberSpec+    ExactTokenSpec+    NicheSpec+    NumericTests+    ScalarLawsSpec+    SourceShape++test-suite moonlight-core-syntax-test+  import: moonlight-core-test-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    test/syntax+    test/support+  main-is: Main.hs+  other-modules:+    LawProperty+    PatternSpec+    SubstitutionSpec+    SyntaxTests+    TheorySpec++test-suite moonlight-core-solver-test+  import: moonlight-core-test-properties+  type: exitcode-stdio-1.0+  hs-source-dirs: test/solver+  main-is: Main.hs+  other-modules:+    FixpointSpec+    SolverTests+    UnionFindSpec++test-suite moonlight-core-term-test+  import: moonlight-core-test-properties+  type: exitcode-stdio-1.0+  hs-source-dirs: test/term+  main-is: Main.hs+  other-modules:+    DatabaseLawSpec+    DatabaseSpec+    TermTests++test-suite moonlight-core-facade-test+  import: moonlight-core-test-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    test/facade+    test/support+  main-is: Main.hs+  other-modules:+    PublicSurfaceSpec+    SourceShape++test-suite moonlight-core-test+  import: moonlight-core-test-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    test/aggregate+    test/basis+    test/numeric+    test/syntax+    test/solver+    test/term+    test/facade+    test/support+  main-is: Main.hs+  other-modules:+    ApproxEqSpec+    BasisTests+    BoundarySpec+    CardinalitySpec+    CanonSpec+    CanonicalNumberSpec+    DatabaseLawSpec+    DatabaseSpec+    DenseKeySpec+    ExactTokenSpec+    FiniteSpec+    FixpointSpec+    IsoNormSpec+    LawProperty+    MapAccumSpec+    NicheSpec+    NumericTests+    OrdCollectionSpec+    OrderSpec+    PatternSpec+    ProofManifestSpec+    PublicSurfaceSpec+    QueueSpec+    RelationalSpec+    ScalarLawsSpec+    SolverTests+    SourceShape+    StableHashSpec+    SubstitutionSpec+    SyntaxTests+    TermTests+    TheorySpec+    TotalRegistrySpec+    TypeLevelSpec+    UnionFindSpec+    ValidationSpec++common moonlight-core-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-core-basis-bench+  import: moonlight-core-benchmark-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    bench/basis+    bench/support+  main-is: Main.hs+  other-modules:+    BasisBench+    BenchSupport+  build-depends:+    bytestring >= 0.11+    , containers >= 0.8+    , deepseq >= 1.4+    , memory >= 0.18+    , moonlight-core+    , moonlight-core:moonlight-core-basis+    , text >= 2.0++benchmark moonlight-core-numeric-bench+  import: moonlight-core-benchmark-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    bench/numeric+    bench/support+  main-is: Main.hs+  other-modules:+    BenchSupport+    NumericBench+  build-depends:+    bytestring >= 0.11+    , moonlight-core+    , moonlight-core:moonlight-core-numeric+    , moonlight-core:moonlight-core-basis+    , scientific >= 0.3++benchmark moonlight-core-syntax-bench+  import: moonlight-core-benchmark-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    bench/syntax+    bench/support+  main-is: Main.hs+  other-modules:+    BenchSupport+    SyntaxBench+  build-depends:+    containers >= 0.8+    , moonlight-core+    , moonlight-core:moonlight-core-basis+    , moonlight-core:moonlight-core-syntax++benchmark moonlight-core-solver-bench+  import: moonlight-core-benchmark-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    bench/solver+    bench/support+  main-is: Main.hs+  other-modules:+    BenchSupport+    SolverBench+  build-depends:+    containers >= 0.8+    , deepseq >= 1.4+    , equivalence >= 0.4+    , moonlight-core+    , moonlight-core:moonlight-core-solver+    , moonlight-core:moonlight-core-basis+    , vector >= 0.13++benchmark moonlight-core-term-bench+  import: moonlight-core-benchmark-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    bench/term+    bench/support+  main-is: Main.hs+  other-modules:+    BenchSupport+    TermBench+  build-depends:+    containers >= 0.8+    , moonlight-core+    , moonlight-core:moonlight-core-term+    , vector >= 0.13++benchmark moonlight-core-bench+  import: moonlight-core-benchmark-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    bench/aggregate+    bench/basis+    bench/numeric+    bench/syntax+    bench/solver+    bench/term+    bench/support+  main-is: Main.hs+  other-modules:+    BasisBench+    BenchSupport+    NumericBench+    SolverBench+    SyntaxBench+    TermBench+  build-depends:+    bytestring >= 0.11+    , containers >= 0.8+    , deepseq >= 1.4+    , equivalence >= 0.4+    , memory >= 0.18+    , moonlight-core+    , moonlight-core:moonlight-core-numeric+    , moonlight-core:moonlight-core-solver+    , moonlight-core:moonlight-core-basis+    , moonlight-core:moonlight-core-syntax+    , moonlight-core:moonlight-core-term+    , scientific >= 0.3+    , text >= 2.0+    , vector >= 0.13
+ src-automata/Moonlight/Automata/Pure/Algebra.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | Bottom-up evaluation and the closure algebra (product, intersection, union, complement) over the automata carriers.+module Moonlight.Automata.Pure.Algebra+  ( evalDBTA,+    annotateBottomUp,+    evalNBTA,+    acceptsDBTA,+    acceptsNBTA,+    dependentDBTA,+    productDBTA,+    intersectionDBTA,+    unionDBTA,+    complementAcceptance,+  )+where++import Control.Comonad.Cofree (Cofree (..))+import Data.Functor.Foldable (Base, Recursive, cata)+import Data.Set qualified as Set+import Moonlight.Automata.Pure.Core+  ( Acceptance,+    AcceptingDBTA (..),+    AcceptingNBTA (..),+    DBTA (..),+    NBTA (..),+    accepts,+    mapAcceptance,+    zipAcceptanceWith,+  )+import Prelude++evalDBTA :: (Recursive t, Base t ~ f) => DBTA f state -> t -> state+evalDBTA (DBTA algebra) = cata algebra++annotateBottomUp :: forall input f state. (Recursive input, Base input ~ f, Functor f) => DBTA f state -> input -> Cofree f state+annotateBottomUp (DBTA algebra) =+  cata annotateLayer+  where+    annotateLayer :: f (Cofree f state) -> Cofree f state+    annotateLayer layer =+      algebra (fmap rootState layer) :< layer++    rootState :: Cofree f state -> state+    rootState (state :< _) = state++evalNBTA :: (Recursive t, Base t ~ f) => NBTA f state -> t -> Set.Set state+evalNBTA (NBTA algebra) = cata algebra++acceptsDBTA :: (Recursive t, Base t ~ f) => AcceptingDBTA f state -> t -> Bool+acceptsDBTA automaton value =+  accepts (adbtaAcceptance automaton) (evalDBTA (adbtaAlgebra automaton) value)++acceptsNBTA :: (Recursive t, Base t ~ f) => AcceptingNBTA f state -> t -> Bool+acceptsNBTA automaton value =+  any+    (accepts (anbtaAcceptance automaton))+    (evalNBTA (anbtaAlgebra automaton) value)++dependentDBTA :: Functor f => DBTA f leftState -> (f (leftState, rightState) -> rightState) -> DBTA f (leftState, rightState)+dependentDBTA (DBTA leftAlgebra) rightAlgebra =+  DBTA+    ( \layer ->+        let leftState = leftAlgebra (fmap fst layer)+            rightState = rightAlgebra layer+         in (leftState, rightState)+    )++productDBTA :: Functor f => DBTA f leftState -> DBTA f rightState -> DBTA f (leftState, rightState)+productDBTA leftAutomaton rightAutomaton =+  dependentDBTA leftAutomaton (runDBTA rightAutomaton . fmap snd)++intersectionDBTA :: Functor f => AcceptingDBTA f leftState -> AcceptingDBTA f rightState -> AcceptingDBTA f (leftState, rightState)+intersectionDBTA =+  combineAcceptingDBTAWith (&&)++unionDBTA :: Functor f => AcceptingDBTA f leftState -> AcceptingDBTA f rightState -> AcceptingDBTA f (leftState, rightState)+unionDBTA =+  combineAcceptingDBTAWith (||)++complementAcceptance :: Acceptance state -> Acceptance state+complementAcceptance =+  mapAcceptance not++combineAcceptingDBTAWith :: Functor f => (Bool -> Bool -> Bool) -> AcceptingDBTA f leftState -> AcceptingDBTA f rightState -> AcceptingDBTA f (leftState, rightState)+combineAcceptingDBTAWith combine leftAutomaton rightAutomaton =+  AcceptingDBTA+    { adbtaAlgebra = productDBTA (adbtaAlgebra leftAutomaton) (adbtaAlgebra rightAutomaton),+      adbtaAcceptance = zipAcceptanceWith combine (adbtaAcceptance leftAutomaton) (adbtaAcceptance rightAutomaton)+    }
+ src-automata/Moonlight/Automata/Pure/Coalgebra.hs view
@@ -0,0 +1,48 @@+-- | Top-down duals: folds and annotations flowing from the root, including inherited attributes.+module Moonlight.Automata.Pure.Coalgebra+  ( topDownFold,+    annotateTopDown,+    annotateTopDownWithAttribute,+    projectStateAnnotation,+    projectAttributeAnnotation,+    rootAttribute,+    inheritedAttribute,+  )+where++import Control.Comonad.Cofree (Cofree (..))+import Data.Functor.Foldable (Base, Recursive (project))+import Moonlight.Automata.Pure.Core (TopDownTA (..))+import Prelude++topDownFold :: (Functor f, Recursive t, Base t ~ f) => TopDownTA f state -> (state -> f result -> result) -> state -> t -> result+topDownFold automaton algebra = go+  where+    go state value =+      let distributedChildren = runTopDownTA automaton state (project value)+       in algebra state (fmap (uncurry go) distributedChildren)++annotateTopDown :: (Functor f, Recursive t, Base t ~ f) => TopDownTA f state -> state -> t -> Cofree f state+annotateTopDown automaton =+  topDownFold automaton (\state annotatedChildren -> state :< annotatedChildren)++annotateTopDownWithAttribute :: (Functor f, Recursive t, Base t ~ f) => TopDownTA f state -> (state -> f attribute -> attribute) -> state -> t -> Cofree f (state, attribute)+annotateTopDownWithAttribute automaton algebra =+  topDownFold+    automaton+    ( \state annotatedChildren ->+        let attribute = algebra state (fmap rootAttribute annotatedChildren)+         in (state, attribute) :< annotatedChildren+    )++projectStateAnnotation :: Functor f => Cofree f (state, attribute) -> Cofree f state+projectStateAnnotation = fmap fst++projectAttributeAnnotation :: Functor f => Cofree f (state, attribute) -> Cofree f attribute+projectAttributeAnnotation = fmap snd++rootAttribute :: Cofree f (state, attribute) -> attribute+rootAttribute ((_, attribute) :< _) = attribute++inheritedAttribute :: (Functor f, Recursive t, Base t ~ f) => TopDownTA f state -> (state -> f attribute -> attribute) -> state -> t -> attribute+inheritedAttribute = topDownFold
+ src-automata/Moonlight/Automata/Pure/Core.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE RankNTypes #-}++-- | The tree-automata carriers: deterministic ('DBTA'), nondeterministic ('NBTA'), and top-down, with 'Acceptance' as the observable.+module Moonlight.Automata.Pure.Core+  ( DBTA (..),+    NBTA (..),+    TopDownTA (..),+    Acceptance (..),+    mapAcceptance,+    zipAcceptanceWith,+    AcceptingDBTA (..),+    AcceptingNBTA (..),+  )+where++import Data.Kind (Type)+import Data.Set (Set)+import Prelude++type DBTA :: (Type -> Type) -> Type -> Type+newtype DBTA f state = DBTA+  { runDBTA :: f state -> state+  }++type NBTA :: (Type -> Type) -> Type -> Type+newtype NBTA f state = NBTA+  { runNBTA :: f (Set state) -> Set state+  }++type TopDownTA :: (Type -> Type) -> Type -> Type+newtype TopDownTA f state = TopDownTA+  { runTopDownTA :: forall child. state -> f child -> f (state, child)+  }++type Acceptance :: Type -> Type+newtype Acceptance state = Acceptance+  { accepts :: state -> Bool+  }++mapAcceptance :: (Bool -> Bool) -> Acceptance state -> Acceptance state+mapAcceptance morphism acceptance =+  Acceptance (morphism . accepts acceptance)++zipAcceptanceWith :: (Bool -> Bool -> Bool) -> Acceptance leftState -> Acceptance rightState -> Acceptance (leftState, rightState)+zipAcceptanceWith combine leftAcceptance rightAcceptance =+  Acceptance+    ( \(leftState, rightState) ->+        combine+    (accepts leftAcceptance leftState)+          (accepts rightAcceptance rightState)+    )++type AcceptingDBTA :: (Type -> Type) -> Type -> Type+data AcceptingDBTA f state = AcceptingDBTA+  { adbtaAlgebra :: DBTA f state,+    adbtaAcceptance :: Acceptance state+  }++type AcceptingNBTA :: (Type -> Type) -> Type -> Type+data AcceptingNBTA f state = AcceptingNBTA+  { anbtaAlgebra :: NBTA f state,+    anbtaAcceptance :: Acceptance state+  }
+ src-automata/Moonlight/Automata/Pure/Transducer.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Tree transducers over contexts: bottom-up, top-down, macro, and lookahead-macro variants, with composition where it is lawful.+module Moonlight.Automata.Pure.Transducer+  ( TreeContext,+    contextHole,+    contextLayer,+    foldTreeContext,+    substituteTreeContext,+    lowerTreeContext,+    BottomUpTransducer (..),+    runBottomUpTransducer,+    composeBottomUp,+    TopDownTransducer (..),+    runTopDownTransducer,+    composeTopDown,+    MacroTreeTransducer (..),+    runMacroTreeTransducer,+    LookaheadMacroTreeTransducer (..),+    runLookaheadMacroTreeTransducer,+  )+where++import Control.Comonad.Cofree (Cofree (..))+import Control.Monad.Free (Free (..), iter)+import Data.Bifunctor (second)+import Data.Functor.Foldable (Base, Corecursive (embed), Recursive (project), cata)+import Data.Kind (Type)+import Moonlight.Automata.Pure.Algebra (annotateBottomUp)+import Moonlight.Automata.Pure.Core (DBTA)+import Prelude++type TreeContext :: (Type -> Type) -> Type -> Type+newtype TreeContext g hole = TreeContext+  { unTreeContext :: Free g hole+  }+  deriving newtype (Functor, Applicative, Monad)++contextHole :: hole -> TreeContext g hole+contextHole =+  TreeContext . Pure++contextLayer :: Functor g => g (TreeContext g hole) -> TreeContext g hole+contextLayer =+  TreeContext . Free . fmap unTreeContext++foldTreeContext :: forall g hole result. Functor g => (hole -> result) -> (g result -> result) -> TreeContext g hole -> result+foldTreeContext holeAlgebra layerAlgebra (TreeContext context) =+  iter layerAlgebra (fmap holeAlgebra context)++substituteTreeContext :: Functor g => (hole -> TreeContext g hole') -> TreeContext g hole -> TreeContext g hole'+substituteTreeContext =+  (=<<)++lowerTreeContext :: (Functor g, Corecursive output, Base output ~ g) => TreeContext g output -> output+lowerTreeContext =+  foldTreeContext id embed++joinTreeContext :: Functor g => TreeContext g (TreeContext g hole) -> TreeContext g hole+joinTreeContext =+  substituteTreeContext id++collapseNestedContext :: Functor g => (TreeContext g hole -> hole) -> TreeContext g (TreeContext g hole) -> hole+collapseNestedContext collapse =+  collapse . joinTreeContext++type BottomUpTransducer ::+  (Type -> Type) -> Type -> (Type -> Type) -> Type+newtype BottomUpTransducer f state g = BottomUpTransducer+  { runBottomUpStep :: forall hole. f (state, hole) -> (state, TreeContext g hole)+  }++runBottomUpTransducer :: (Recursive input, Base input ~ f, Corecursive output, Base output ~ g, Functor g) => BottomUpTransducer f state g -> input -> output+runBottomUpTransducer transducer =+  snd . cata (second lowerTreeContext . runBottomUpStep transducer)++composeBottomUp :: forall f g h innerState outerState. (Functor f, Functor g, Functor h) => BottomUpTransducer g innerState h -> BottomUpTransducer f outerState g -> BottomUpTransducer f (outerState, innerState) h+composeBottomUp innerTransducer outerTransducer =+  BottomUpTransducer composedStep+  where+    composedStep :: forall hole. f ((outerState, innerState), hole) -> ((outerState, innerState), TreeContext h hole)+    composedStep layer =+      let outerLayer =+            fmap+              (\((parentOuterState, parentInnerState), hole) -> (parentOuterState, (parentInnerState, hole)))+              layer+          (outerState, intermediateTerm) = runBottomUpStep outerTransducer outerLayer+          (innerState, outputTerm) = lowerIntermediate intermediateTerm+       in ((outerState, innerState), outputTerm)++    lowerIntermediate :: forall hole. TreeContext g (innerState, hole) -> (innerState, TreeContext h hole)+    lowerIntermediate =+      foldTreeContext+        (second contextHole)+        (second joinTreeContext . runBottomUpStep innerTransducer)++type TopDownTransducer ::+  (Type -> Type) -> Type -> (Type -> Type) -> Type+newtype TopDownTransducer f state g = TopDownTransducer+  { runTopDownStep :: forall child. state -> f child -> TreeContext g (state, child)+  }++runTopDownTransducer :: forall input f output g state. (Recursive input, Base input ~ f, Corecursive output, Base output ~ g, Functor g) => TopDownTransducer f state g -> state -> input -> output+runTopDownTransducer transducer =+  go+  where+    go :: state -> input -> output+    go state value =+      lowerTreeContext+        ( runTopDownStep transducer state (project value)+            >>= contextHole . uncurry go+        )++composeTopDown :: forall f g h innerState outerState. (Functor g, Functor h) => TopDownTransducer g innerState h -> TopDownTransducer f outerState g -> TopDownTransducer f (outerState, innerState) h+composeTopDown innerTransducer outerTransducer =+  TopDownTransducer composedStep+  where+    composedStep :: forall child. (outerState, innerState) -> f child -> TreeContext h ((outerState, innerState), child)+    composedStep (outerState, innerState) layer =+      lowerOuterContext (runTopDownStep outerTransducer outerState layer) innerState++    lowerOuterContext :: forall child. TreeContext g (outerState, child) -> innerState -> TreeContext h ((outerState, innerState), child)+    lowerOuterContext =+      foldTreeContext descendIntoHole descendIntoLayer++    descendIntoHole :: forall child. (outerState, child) -> innerState -> TreeContext h ((outerState, innerState), child)+    descendIntoHole (outerState, child) innerState =+      contextHole ((outerState, innerState), child)++    descendIntoLayer :: forall child. g (innerState -> TreeContext h ((outerState, innerState), child)) -> innerState -> TreeContext h ((outerState, innerState), child)+    descendIntoLayer childContinuations innerState =+      runTopDownStep innerTransducer innerState childContinuations+        >>= uncurry (flip ($))++type MacroTreeTransducer ::+  (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Type+newtype MacroTreeTransducer f macroState g = MacroTreeTransducer+  { runMacroStep ::+      forall hole.+      macroState hole ->+      f (macroState (TreeContext g hole) -> hole) ->+      TreeContext g hole+  }++runMacroTreeTransducer :: (Recursive input, Base input ~ f, Corecursive output, Base output ~ g, Functor f, Functor g) => MacroTreeTransducer f macroState g -> macroState output -> input -> output+runMacroTreeTransducer transducer initialState input =+  lowerTreeContext (runMacroContext lowerTreeContext transducer initialState input)++runMacroContext ::+  forall input f g hole macroState.+  (Recursive input, Base input ~ f, Functor f, Functor g) =>+  (TreeContext g hole -> hole) ->+  MacroTreeTransducer f macroState g ->+  macroState hole ->+  input ->+  TreeContext g hole+runMacroContext collapse transducer state value =+  runMacroStep+    transducer+    state+    (fmap childContinuation (project value))+  where+    childContinuation :: input -> macroState (TreeContext g hole) -> hole+    childContinuation child childState =+      collapseNestedContext collapse (runMacroContext joinTreeContext transducer childState child)++type LookaheadMacroTreeTransducer ::+  (Type -> Type) -> Type -> (Type -> Type) -> (Type -> Type) -> Type+newtype LookaheadMacroTreeTransducer f lookahead macroState g = LookaheadMacroTreeTransducer+  { runLookaheadMacroStep ::+      forall hole.+      macroState hole ->+      lookahead ->+      f (macroState (TreeContext g hole) -> hole, lookahead) ->+      TreeContext g hole+  }++runLookaheadMacroTreeTransducer :: (Recursive input, Base input ~ f, Corecursive output, Base output ~ g, Functor f, Functor g) => DBTA f lookahead -> LookaheadMacroTreeTransducer f lookahead macroState g -> macroState output -> input -> output+runLookaheadMacroTreeTransducer lookaheadAutomaton transducer initialState input =+  lowerTreeContext (runLookaheadMacroContext lowerTreeContext transducer initialState annotatedInput)+  where+    annotatedInput = annotateBottomUp lookaheadAutomaton input++runLookaheadMacroContext ::+  forall f g hole lookahead macroState.+  (Functor f, Functor g) =>+  (TreeContext g hole -> hole) ->+  LookaheadMacroTreeTransducer f lookahead macroState g ->+  macroState hole ->+  Cofree f lookahead ->+  TreeContext g hole+runLookaheadMacroContext collapse transducer state (lookahead :< layer) =+  runLookaheadMacroStep+    transducer+    state+    lookahead+    (fmap childContinuation layer)+  where+    childContinuation :: Cofree f lookahead -> (macroState (TreeContext g hole) -> hole, lookahead)+    childContinuation child@(childLookahead :< _) =+      ( \childState -> collapseNestedContext collapse (runLookaheadMacroContext joinTreeContext transducer childState child),+        childLookahead+      )
+ src-automata/Moonlight/Core/Pattern/Automata.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Bottom-up matcher for compiled pattern kernels.+-- It owns deterministic tree-automaton evaluation, conjunction by kernel+-- intersection, and binding compatibility checks against existing bindings.+module Moonlight.Core.Pattern.Automata+  ( PatternAutomaton,+    compilePatternAutomaton,+    compileConjunctivePatternAutomaton,+    intersectPatternAutomaton,+    matchesPatternAutomaton,+    matchPatternAutomaton,+  )+where++import Data.Foldable (foldlM, toList)+import Data.Fix (Fix (..))+import Data.Kind (Type)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (isJust, mapMaybe)+import Data.These (These (..))+import Moonlight.Core.Fix.Order (OrderedFix (..))+import Moonlight.Core.Identifier.EGraph (PatternVar, patternVarKey)+import Moonlight.Core.Language (Language, ZipMatch (..))+import Moonlight.Core.Pattern (Pattern)+import Moonlight.Core.Pattern.Kernel+  ( CompiledPatternKernel (..),+    PatternKernelChildren (..),+    PatternKernelStateSpec (..),+    compilePatternKernel,+    intersectCompiledPatternKernel,+  )+import Moonlight.Automata.Pure.Algebra (evalDBTA)+import Moonlight.Automata.Pure.Core (DBTA (..))+import Prelude++type PatternState :: (Type -> Type) -> Type -> Type+data PatternState f state = PatternState+  { patternStateTerm :: Fix f,+    patternStateBindings :: Map state (IntMap (Fix f))+  }++type PatternAutomaton :: (Type -> Type) -> Type+data PatternAutomaton f where+  PatternAutomaton :: Ord state => CompiledPatternKernel f state -> DBTA f (PatternState f state) -> PatternAutomaton f++compilePatternAutomaton :: (Language f, ZipMatch f) => Pattern f -> PatternAutomaton f+compilePatternAutomaton =+  patternAutomatonFromKernel . compilePatternKernel++compileConjunctivePatternAutomaton :: (Language f, ZipMatch f) => NonEmpty (Pattern f) -> PatternAutomaton f+compileConjunctivePatternAutomaton (patternValue :| patternValues) =+  foldl'+    intersectPatternAutomaton+    (compilePatternAutomaton patternValue)+    (fmap compilePatternAutomaton patternValues)++intersectPatternAutomaton :: (Language f, ZipMatch f) => PatternAutomaton f -> PatternAutomaton f -> PatternAutomaton f+intersectPatternAutomaton (PatternAutomaton leftKernel _) (PatternAutomaton rightKernel _) =+  patternAutomatonFromKernel (intersectCompiledPatternKernel leftKernel rightKernel)++matchesPatternAutomaton :: Language f => PatternAutomaton f -> Fix f -> Bool+matchesPatternAutomaton automaton term =+  isJust (matchPatternAutomaton automaton term IntMap.empty)++matchPatternAutomaton :: Language f => PatternAutomaton f -> Fix f -> IntMap (Fix f) -> Maybe (IntMap (Fix f))+matchPatternAutomaton (PatternAutomaton kernel automaton) term initialBindings =+  mergeBindings initialBindings+    =<< rootBindingsFor kernel (evalDBTA automaton term)++patternAutomatonFromKernel :: (Language f, ZipMatch f, Ord state) => CompiledPatternKernel f state -> PatternAutomaton f+patternAutomatonFromKernel kernel =+  PatternAutomaton kernel (DBTA (stepPatternKernelAutomaton kernel))++stepPatternKernelAutomaton :: (Language f, ZipMatch f, Ord state) => CompiledPatternKernel f state -> f (PatternState f state) -> PatternState f state+stepPatternKernelAutomaton kernel childStates =+  let currentTerm = Fix (fmap patternStateTerm childStates)+      stateBindings =+        Map.fromList+          (mapMaybe+             (\state ->+                fmap+                  ((,) state)+                  (matchKernelState currentTerm childStates (cpkStateSpec kernel state))+             )+             (cpkOrderedStates kernel))+   in PatternState currentTerm stateBindings++matchKernelState :: (Language f, ZipMatch f, Ord state) => Fix f -> f (PatternState f state) -> PatternKernelStateSpec f state -> Maybe (IntMap (Fix f))+matchKernelState currentTerm childStates stateSpec =+  case runPatternKernelStateSpec stateSpec of+    (_, KernelMatchImpossible) ->+      Nothing+    (patternVars, KernelMatchAny) ->+      bindCurrentTerm patternVars currentTerm IntMap.empty+    (patternVars, KernelMatchNode patternNode) ->+      zipMatchedChildren patternNode childStates+        >>= foldlM mergeChildBindings IntMap.empty . toList+        >>= bindCurrentTerm patternVars currentTerm++zipMatchedChildren ::+  ZipMatch f =>+  f state ->+  f child ->+  Maybe (f (state, child))+zipMatchedChildren patternNode childValues =+  traverse matchedChild+    =<< zipMatch (fmap This patternNode) (fmap That childValues)+  where+    matchedChild ::+      (These state child, These state child) ->+      Maybe (state, child)+    matchedChild matchedValue =+      case matchedValue of+        (This stateValue, That childValue) ->+          Just (stateValue, childValue)+        _ ->+          Nothing++mergeChildBindings :: (Language f, Ord state) => IntMap (Fix f) -> (state, PatternState f state) -> Maybe (IntMap (Fix f))+mergeChildBindings bindings (state, childState) =+  Map.lookup state (patternStateBindings childState)+    >>= mergeBindings bindings++bindCurrentTerm :: Language f => [PatternVar] -> Fix f -> IntMap (Fix f) -> Maybe (IntMap (Fix f))+bindCurrentTerm patternVars boundTerm bindings =+  foldlM+    (\currentBindings patternVar -> bindPatternVar patternVar boundTerm currentBindings)+    bindings+    patternVars++bindPatternVar :: Language f => PatternVar -> Fix f -> IntMap (Fix f) -> Maybe (IntMap (Fix f))+bindPatternVar patternVar boundTerm bindings =+  case IntMap.lookup (patternVarKey patternVar) bindings of+    Nothing ->+      Just (IntMap.insert (patternVarKey patternVar) boundTerm bindings)+    Just existingTerm+      | OrderedFix existingTerm == OrderedFix boundTerm -> Just bindings+      | otherwise -> Nothing++mergeBindings :: forall f. Language f => IntMap (Fix f) -> IntMap (Fix f) -> Maybe (IntMap (Fix f))+mergeBindings initialBindings =+  foldlM mergeEntry initialBindings . IntMap.toAscList+  where+    mergeEntry :: IntMap (Fix f) -> (IntMap.Key, Fix f) -> Maybe (IntMap (Fix f))+    mergeEntry bindings (bindingKey, boundTerm) =+      case IntMap.lookup bindingKey bindings of+        Nothing -> Just (IntMap.insert bindingKey boundTerm bindings)+        Just existingTerm+          | OrderedFix existingTerm == OrderedFix boundTerm -> Just bindings+          | otherwise -> Nothing++rootBindingsFor :: Ord state => CompiledPatternKernel f state -> PatternState f state -> Maybe (IntMap (Fix f))+rootBindingsFor kernel stateValue =+  Map.lookup (cpkRootState kernel) (patternStateBindings stateValue)
+ src-automata/Moonlight/Core/Pattern/Kernel.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE LambdaCase #-}++-- | Compilation of authored patterns into intersectable bottom-up kernels consumed by the pattern automata.+module Moonlight.Core.Pattern.Kernel+  ( PatternKernelChildren (..),+    PatternKernelStateSpec (..),+    CompiledPatternKernel (..),+    compilePatternKernel,+    intersectCompiledPatternKernel,+    kernelStateChildren,+  )+where++import Control.Monad.Trans.State.Strict (State, runState, state)+import Data.Foldable (toList)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Kind (Type)+import Data.Set qualified as Set+import Data.These (These (..))+import Moonlight.Core.Identifier.EGraph (PatternVar)+import Moonlight.Core.Language (ZipMatch (..))+import Moonlight.Core.Pattern (Pattern (..))+import Prelude++type PatternKernelChildren :: (Type -> Type) -> Type -> Type+data PatternKernelChildren f state+  = KernelMatchAny+  | KernelMatchNode (f state)+  | KernelMatchImpossible++type PatternKernelStateSpec :: (Type -> Type) -> Type -> Type+newtype PatternKernelStateSpec f state = PatternKernelStateSpec+  { runPatternKernelStateSpec :: ([PatternVar], PatternKernelChildren f state)+  }++patternKernelBindings :: PatternKernelStateSpec f state -> [PatternVar]+patternKernelBindings = fst . runPatternKernelStateSpec++patternKernelChildren :: PatternKernelStateSpec f state -> PatternKernelChildren f state+patternKernelChildren = snd . runPatternKernelStateSpec++type CompiledPatternKernel :: (Type -> Type) -> Type -> Type+data CompiledPatternKernel f state = CompiledPatternKernel+  { cpkRootState :: state,+    cpkOrderedStates :: [state],+    cpkStateSpec :: state -> PatternKernelStateSpec f state+  }++type PatternNodeId :: Type+newtype PatternNodeId = PatternNodeId+  { patternNodeIdKey :: Int+  }+  deriving stock (Eq, Ord, Show)++type FlatPatternNode :: (Type -> Type) -> Type+data FlatPatternNode f+  = FlatPatternVar PatternVar+  | FlatPatternNode (f PatternNodeId)++type PatternNodeBuilder :: (Type -> Type) -> Type+data PatternNodeBuilder f = PatternNodeBuilder+  { pnbNextKey :: Int,+    pnbNodes :: IntMap (FlatPatternNode f)+  }++emptyPatternNodeBuilder :: PatternNodeBuilder f+emptyPatternNodeBuilder =+  PatternNodeBuilder+    { pnbNextKey = 0,+      pnbNodes = IntMap.empty+    }++compilePatternKernel :: Traversable f => Pattern f -> CompiledPatternKernel f PatternNodeId+compilePatternKernel patternValue =+  let (rootNodeId, finalBuilder) =+        runState+          (compilePatternNode patternValue)+          emptyPatternNodeBuilder+      compiledNodesById = pnbNodes finalBuilder+   in CompiledPatternKernel+        { cpkRootState = rootNodeId,+          cpkOrderedStates = fmap PatternNodeId (IntMap.keys compiledNodesById),+          cpkStateSpec =+            \patternNodeId ->+              maybe+                (PatternKernelStateSpec ([], KernelMatchImpossible))+                compiledNodeKernelSpec+                (IntMap.lookup (patternNodeIdKey patternNodeId) compiledNodesById)+        }++compilePatternNode :: Traversable f => Pattern f -> State (PatternNodeBuilder f) PatternNodeId+compilePatternNode patternValue =+  case patternValue of+    PatternVar patternVar ->+      registerPatternNode (FlatPatternVar patternVar)+    PatternNode patternNode ->+      traverse compilePatternNode patternNode >>= registerPatternNode . FlatPatternNode++registerPatternNode :: FlatPatternNode f -> State (PatternNodeBuilder f) PatternNodeId+registerPatternNode flatPatternNode =+  state+    ( \builder ->+        let nextNodeId = PatternNodeId (pnbNextKey builder)+         in ( nextNodeId,+              builder+                { pnbNextKey = pnbNextKey builder + 1,+                  pnbNodes = IntMap.insert (patternNodeIdKey nextNodeId) flatPatternNode (pnbNodes builder)+                }+            )+    )++compiledNodeKernelSpec :: FlatPatternNode f -> PatternKernelStateSpec f PatternNodeId+compiledNodeKernelSpec compiledNode =+  case compiledNode of+    FlatPatternVar patternVar ->+      PatternKernelStateSpec ([patternVar], KernelMatchAny)+    FlatPatternNode patternNode ->+      PatternKernelStateSpec ([], KernelMatchNode patternNode)++intersectCompiledPatternKernel :: (ZipMatch f, Ord leftState, Ord rightState) => CompiledPatternKernel f leftState -> CompiledPatternKernel f rightState -> CompiledPatternKernel f (These leftState rightState)+intersectCompiledPatternKernel leftKernel rightKernel =+  CompiledPatternKernel+    { cpkRootState = rootState,+      cpkOrderedStates = reachableOrderedStates describeProductState rootState,+      cpkStateSpec = describeProductState+    }+  where+    rootState = These (cpkRootState leftKernel) (cpkRootState rightKernel)+    describeProductState productState =+      case productState of+        This leftState ->+          combineStateSpecs+            (cpkStateSpec leftKernel leftState)+            wildcardPatternKernelStateSpec+        That rightState ->+          combineStateSpecs+            wildcardPatternKernelStateSpec+            (cpkStateSpec rightKernel rightState)+        These leftState rightState ->+          combineStateSpecs+            (cpkStateSpec leftKernel leftState)+            (cpkStateSpec rightKernel rightState)++wildcardPatternKernelStateSpec :: PatternKernelStateSpec f state+wildcardPatternKernelStateSpec = PatternKernelStateSpec ([], KernelMatchAny)++combineStateSpecs :: ZipMatch f => PatternKernelStateSpec f leftState -> PatternKernelStateSpec f rightState -> PatternKernelStateSpec f (These leftState rightState)+combineStateSpecs leftSpec rightSpec =+  PatternKernelStateSpec+    ( patternKernelBindings leftSpec <> patternKernelBindings rightSpec,+      combineChildStates (patternKernelChildren leftSpec) (patternKernelChildren rightSpec)+    )++combineChildStates :: ZipMatch f => PatternKernelChildren f leftState -> PatternKernelChildren f rightState -> PatternKernelChildren f (These leftState rightState)+combineChildStates leftChildren rightChildren =+  case (leftChildren, rightChildren) of+    (KernelMatchImpossible, _) -> KernelMatchImpossible+    (_, KernelMatchImpossible) -> KernelMatchImpossible+    (KernelMatchAny, KernelMatchAny) -> KernelMatchAny+    (KernelMatchNode leftNode, KernelMatchAny) ->+      KernelMatchNode (fmap This leftNode)+    (KernelMatchAny, KernelMatchNode rightNode) ->+      KernelMatchNode (fmap That rightNode)+    (KernelMatchNode leftNode, KernelMatchNode rightNode) ->+      maybe KernelMatchImpossible KernelMatchNode (zipMatchedChildStates leftNode rightNode)++reachableOrderedStates :: (Ord state, Foldable f) => (state -> PatternKernelStateSpec f state) -> state -> [state]+reachableOrderedStates describeState rootState =+  reverse (snd (visitState mempty [] rootState))+  where+    visitState visited orderedStates currentState+      | Set.member currentState visited = (visited, orderedStates)+      | otherwise =+          let visitedWithState = Set.insert currentState visited+              (visitedAfterChildren, orderedStatesAfterChildren) =+                foldl'+                  (\(childVisited, childOrderedStates) childState -> visitState childVisited childOrderedStates childState)+                  (visitedWithState, orderedStates)+                  (kernelStateChildren (patternKernelChildren (describeState currentState)))+           in (visitedAfterChildren, currentState : orderedStatesAfterChildren)++kernelStateChildren :: Foldable f => PatternKernelChildren f state -> [state]+kernelStateChildren kernelChildren =+  case kernelChildren of+    KernelMatchAny -> []+    KernelMatchNode childStates -> toList childStates+    KernelMatchImpossible -> []++zipMatchedChildStates ::+  ZipMatch f =>+  f leftState ->+  f rightState ->+  Maybe (f (These leftState rightState))+zipMatchedChildStates leftChildren rightChildren =+  traverse matchedChildState+    =<< zipMatch (fmap This leftChildren) (fmap That rightChildren)+  where+    matchedChildState ::+      (These leftState rightState, These leftState rightState) ->+      Maybe (These leftState rightState)+    matchedChildState =+      \case+        (This leftState, That rightState) ->+          Just (These leftState rightState)+        _ ->+          Nothing
+ src-basis/Moonlight/Core/Aggregate.hs view
@@ -0,0 +1,110 @@+-- | Small total aggregation utilities over lists and foldables: safe indexing,+-- pairwise/adjacent folds, extrema, averages, spreads and unit-interval clamping.+module Moonlight.Core.Aggregate+  ( adjacentPairs,+    averageOf,+    maximumOf,+    minimumOf,+    minimumPositive,+    note,+    pairwise,+    safeIndex,+    safeIndexNatural,+    spectralGap,+    spreadOf,+    clampUnitInterval,+  )+where++import Data.List (foldl', genericDrop, sort, tails)+import Numeric.Natural (Natural)+import Prelude+  ( Double,+    Either (..),+    Int,+    Maybe (..),+    Num,+    Ord,+    drop,+    filter,+    fromIntegral,+    isNaN,+    length,+    max,+    maybe,+    min,+    otherwise,+    (+),+    (/),+    (-),+    (<),+    (<$>),+    (<*>),+    (>),+  )++averageOf :: [Double] -> Maybe Double+averageOf values =+  case values of+    [] -> Nothing+    _ -> Just (foldl' (+) 0.0 values / fromIntegral (length values))++minimumOf :: Ord value => [value] -> Maybe value+minimumOf values =+  case values of+    [] -> Nothing+    firstValue : restValues -> Just (foldl' min firstValue restValues)++maximumOf :: Ord value => [value] -> Maybe value+maximumOf values =+  case values of+    [] -> Nothing+    firstValue : restValues -> Just (foldl' max firstValue restValues)++minimumPositive :: (Ord value, Num value) => [value] -> Maybe value+minimumPositive values =+  case filter (> 0) values of+    [] -> Nothing+    firstValue : restValues -> Just (foldl' min firstValue restValues)++pairwise :: [value] -> [(value, value)]+pairwise values = [(x, y) | (x : ys) <- tails values, y <- ys]++spectralGap :: (Ord value, Num value) => [value] -> Maybe value+spectralGap values =+  case sort values of+    firstValue : secondValue : _ -> Just (secondValue - firstValue)+    _ -> Nothing++spreadOf :: (Ord value, Num value) => [value] -> Maybe value+spreadOf values =+  (-) <$> maximumOf values <*> minimumOf values++clampUnitInterval :: Double -> Double+clampUnitInterval value+  | isNaN value = value+  | otherwise = max 0.0 (min 1.0 value)++note :: e -> Maybe a -> Either e a+note e = maybe (Left e) Right++safeIndex :: Int -> [a] -> Maybe a+safeIndex idx xs+  | idx < 0 = Nothing+  | otherwise = case drop idx xs of+      [] -> Nothing+      (x : _) -> Just x++safeIndexNatural :: Natural -> [a] -> Maybe a+safeIndexNatural idx xs =+  case genericDrop idx xs of+    [] -> Nothing+    (x : _) -> Just x++adjacentPairs :: [a] -> [(a, a)]+adjacentPairs values =+  case values of+    leftValue : rightValue : remainingValues ->+      (leftValue, rightValue) : adjacentPairs (rightValue : remainingValues)+    _ ->+      []
+ src-basis/Moonlight/Core/Boundary.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TypeFamilies #-}++-- | The 'BoundaryOps' class: overlap, restriction, compatibility and subsumption+-- of region boundaries via an associated overlap type.+module Moonlight.Core.Boundary+  ( BoundaryOps (..),+  )+where++import Data.Kind (Constraint, Type)+import Prelude (Bool, Either)++type BoundaryOps :: Type -> Constraint+class BoundaryOps boundary where+  type BoundaryOverlap boundary :: Type++  overlapBetweenBoundary :: boundary -> boundary -> BoundaryOverlap boundary+  restrictBoundaryRaw :: BoundaryOverlap boundary -> boundary -> boundary+  compatibleBoundaryRaw :: boundary -> boundary -> Either boundary boundary+  subsumesBoundaryRaw :: boundary -> boundary -> Bool
+ src-basis/Moonlight/Core/Capability.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}++-- | A constraint captured as data: 'Capability' packs @requirement phase@ evidence with a payload; 'withCapability' releases it.+module Moonlight.Core.Capability+  ( Capability,+    mkCapability,+    withCapability,+    mapCapability,+  )+where++import Data.Kind (Constraint, Type)++type Capability :: forall kindValue. (kindValue -> Constraint) -> kindValue -> Type -> Type+data Capability (requirement :: kindValue -> Constraint) (phase :: kindValue) payload where+  Capability :: requirement phase => payload -> Capability requirement phase payload++mkCapability :: requirement phase => payload -> Capability requirement phase payload+mkCapability = Capability++withCapability :: Capability requirement phase payload -> (requirement phase => payload -> result) -> result+withCapability (Capability payload) use = use payload++mapCapability ::+  (payload -> nextPayload) ->+  Capability requirement phase payload ->+  Capability requirement phase nextPayload+mapCapability transform (Capability payload) =+  Capability (transform payload)
+ src-basis/Moonlight/Core/Cardinality.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DerivingStrategies #-}++module Moonlight.Core.Cardinality+  ( CardinalityFailure (..),+    checkedNaturalToInt,+    checkedNonNegativeProduct,+    checkedNonNegativeSum,+  )+where++import Numeric.Natural (Natural)+import Prelude++data CardinalityFailure+  = NegativeCardinalityFactor Int+  | NaturalCardinalityExceedsIntRange Natural+  | CardinalityProductExceedsIntRange Int Int+  | CardinalitySumExceedsIntRange Int Int+  deriving stock (Eq, Show)++checkedNaturalToInt :: Natural -> Either CardinalityFailure Int+checkedNaturalToInt cardinality+  | cardinality > fromIntegral (maxBound :: Int) =+      Left (NaturalCardinalityExceedsIntRange cardinality)+  | otherwise =+      Right (fromIntegral cardinality)++checkedNonNegativeProduct :: Int -> Int -> Either CardinalityFailure Int+checkedNonNegativeProduct =+  checkedNonNegativeBinary CardinalityProductExceedsIntRange (*)++checkedNonNegativeSum :: Int -> Int -> Either CardinalityFailure Int+checkedNonNegativeSum =+  checkedNonNegativeBinary CardinalitySumExceedsIntRange (+)++checkedNonNegativeBinary ::+  (Int -> Int -> CardinalityFailure) ->+  (Integer -> Integer -> Integer) ->+  Int ->+  Int ->+  Either CardinalityFailure Int+checkedNonNegativeBinary rangeFailure combine left right+  | left < 0 = Left (NegativeCardinalityFactor left)+  | right < 0 = Left (NegativeCardinalityFactor right)+  | combinedValue > toInteger (maxBound :: Int) =+      Left (rangeFailure left right)+  | otherwise = Right (fromInteger combinedValue)+  where+    combinedValue = combine (toInteger left) (toInteger right)+{-# INLINE checkedNonNegativeBinary #-}
+ src-basis/Moonlight/Core/Dedup.hs view
@@ -0,0 +1,52 @@+-- | Stable deduplication and duplicate detection over lists, keyed by an+-- 'Ord'-projection.+module Moonlight.Core.Dedup+  ( dedupStableOn,+    duplicatesOrd,+    firstDuplicate,+    duplicateValuesOn,+  )+where++import Data.Map.Strict qualified as Map+import Data.Maybe (Maybe (Just, Nothing), catMaybes, listToMaybe)+import Data.Set qualified as Set+import Data.Traversable (mapAccumL)+import Prelude (Ord, fmap, id, snd, (.))++dedupStableOn :: Ord key => (value -> key) -> [value] -> [value]+dedupStableOn keyOf =+  catMaybes+    . snd+    . mapAccumL observe Set.empty+  where+    observe seen value =+      let valueKey = keyOf value+       in if Set.member valueKey seen+            then (seen, Nothing)+            else (Set.insert valueKey seen, Just value)++duplicatesOrd :: Ord value => [value] -> [value]+duplicatesOrd =+  Set.toAscList+    . Set.fromList+    . fmap snd+    . duplicateValuesOn id++firstDuplicate :: Ord value => [value] -> Maybe value+firstDuplicate =+  fmap snd . listToMaybe . duplicateValuesOn id++duplicateValuesOn :: Ord key => (value -> key) -> [value] -> [(value, value)]+duplicateValuesOn keyOf =+  catMaybes+    . snd+    . mapAccumL observe Map.empty+  where+    observe firstByKey value =+      let valueKey = keyOf value+       in case Map.lookup valueKey firstByKey of+            Nothing ->+              (Map.insert valueKey value firstByKey, Nothing)+            Just firstValue ->+              (firstByKey, Just (firstValue, value))
+ src-basis/Moonlight/Core/DenseKey.hs view
@@ -0,0 +1,19 @@+-- | The 'DenseKey' class: a stable round-tripping encoding between a key type+-- and an 'Int' key. Callers that require compact non-negative ranges must state+-- that stronger storage invariant separately.+module Moonlight.Core.DenseKey+  ( DenseKey (..),+  )+where++import Data.Kind (Constraint, Type)+import Prelude (Eq, Int, Ord, id)++type DenseKey :: Type -> Constraint+class (Eq key, Ord key) => DenseKey key where+  encodeDenseKey :: key -> Int+  decodeDenseKey :: Int -> key++instance DenseKey Int where+  encodeDenseKey = id+  decodeDenseKey = id
+ src-basis/Moonlight/Core/DomainId.hs view
@@ -0,0 +1,9 @@+-- | Checked textual identifier for value domains: 'mkDomainId' is the only public door, rendering is total.+module Moonlight.Core.DomainId+  ( DomainId,+    mkDomainId,+    renderDomainId,+  )+where++import Moonlight.Core.DomainId.Internal
+ src-basis/Moonlight/Core/DomainId/Internal.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DerivingStrategies #-}++module Moonlight.Core.DomainId.Internal+  ( DomainId,+    mkDomainId,+    unsafeTrustDomainId,+    renderDomainId,+  )+where++import Data.Kind (Type)+import Data.Text (Text)+import Moonlight.Core.Identifier+  ( IdentifierToken,+    mkScopedIdentifier,+    renderScopedIdentifier,+  )+import Moonlight.Internal.Unsound (TrustJustification, unsafelyTrustIdentifierToken)+import Prelude (Eq, Maybe, Ord, Show)++type DomainIdNamespace :: Type+data DomainIdNamespace++type DomainId :: Type+newtype DomainId = DomainId (IdentifierToken DomainIdNamespace)+  deriving stock (Eq, Ord, Show)++mkDomainId :: Text -> Maybe DomainId+mkDomainId =+  mkScopedIdentifier DomainId++unsafeTrustDomainId :: TrustJustification -> Text -> DomainId+unsafeTrustDomainId justification rawInput =+  DomainId (unsafelyTrustIdentifierToken justification rawInput)++renderDomainId :: DomainId -> Text+renderDomainId =+  renderScopedIdentifier (\(DomainId identifierToken) -> identifierToken)
+ src-basis/Moonlight/Core/Error.hs view
@@ -0,0 +1,53 @@++-- | Shared error vocabulary for checked numeric construction; each constructor names the violated precondition.+module Moonlight.Core.Error+  ( MoonlightError (..),+    MoonlightErrorContext (..),+    NonFiniteInput (..),+    renderMoonlightError,+  )+where++import Data.Kind (Type)+import Data.Word (Word32)+import Prelude (Eq, Show, String, show, (<>))++type MoonlightErrorContext :: Type+data MoonlightErrorContext+  = CanonicalizeContext+  | QuantizeContext+  | DomainContext !String+  deriving stock (Eq, Show)++type NonFiniteInput :: Type+data NonFiniteInput+  = NaNInput+  | InfiniteInput+  deriving stock (Eq, Show)++type MoonlightError :: Type+data MoonlightError+  = NonFiniteValue !MoonlightErrorContext !NonFiniteInput+  | QuantizePrecisionTooLarge !Word32+  | NonPositiveValue !MoonlightErrorContext+  | NegativeValue !MoonlightErrorContext+  | NonCanonicalFiniteValue+  | InvariantViolation !String+  deriving stock (Eq, Show)++renderMoonlightError :: MoonlightError -> String+renderMoonlightError errorValue =+  case errorValue of+    NonFiniteValue CanonicalizeContext NaNInput -> "NaN"+    NonFiniteValue CanonicalizeContext InfiniteInput -> "Infinite"+    QuantizePrecisionTooLarge precision -> "quantize precision exceeds 9: " <> show precision+    NonFiniteValue QuantizeContext NaNInput -> "NaN in quantization"+    NonFiniteValue QuantizeContext InfiniteInput -> "Infinite in quantization"+    NonFiniteValue (DomainContext label) NaNInput -> label <> " must not be NaN"+    NonFiniteValue (DomainContext label) InfiniteInput -> label <> " must be finite"+    NonPositiveValue (DomainContext label) -> label <> " must be positive"+    NegativeValue (DomainContext label) -> label <> " must be non-negative"+    NonCanonicalFiniteValue -> "Non-canonical finite value"+    InvariantViolation label -> label+    NonPositiveValue context -> "NonPositiveValue " <> show context+    NegativeValue context -> "NegativeValue " <> show context
+ src-basis/Moonlight/Core/Finite.hs view
@@ -0,0 +1,43 @@+-- | The 'FiniteUniverse' class enumerating a type's finitely many inhabitants,+-- with list/set projections and a 'Bounded'/'Enum' default.+module Moonlight.Core.Finite+  ( FiniteUniverse (..),+    finiteUniverseList,+    finiteUniverseSet,+    boundedEnumUniverse,+  )+where++import Data.List.NonEmpty+  ( NonEmpty (..),+  )+import Data.Set+  ( Set,+  )+import Data.Set qualified as Set+import Prelude+  ( Bounded (..),+    Enum,+    Ord,+    drop,+    enumFromTo,+  )++-- | Law: 'finiteUniverse' enumerates every inhabitant of @value@ exactly once.+-- Total finite structures may rely on any @value@ appearing in this list.+class FiniteUniverse value where+  finiteUniverse :: NonEmpty value++finiteUniverseList :: FiniteUniverse value => [value]+finiteUniverseList =+  case finiteUniverse of+    first :| rest ->+      first : rest++finiteUniverseSet :: (FiniteUniverse value, Ord value) => Set value+finiteUniverseSet =+  Set.fromList finiteUniverseList++boundedEnumUniverse :: forall value. (Bounded value, Enum value) => NonEmpty value+boundedEnumUniverse =+  minBound :| drop 1 (enumFromTo minBound maxBound)
+ src-basis/Moonlight/Core/Hash.hs view
@@ -0,0 +1,23 @@+-- | Word64 hash-mixing primitives and the golden-ratio constant.+module Moonlight.Core.Hash+  ( mixWord64,+    deriveSeedWord,+    goldenRatioConstant,+  )+where++import Data.Bits (shiftL, shiftR, xor)+import Data.Word (Word64)+import Prelude++goldenRatioConstant :: Word64+goldenRatioConstant = 0x9e3779b97f4a7c15++mixWord64 :: Word64 -> Word64 -> Word64+mixWord64 leftValue rightValue =+  let mixed = leftValue `xor` (rightValue + goldenRatioConstant + shiftL leftValue 6 + shiftR leftValue 2)+   in mixed * 0xbf58476d1ce4e5b9 + 0x94d049bb133111eb++deriveSeedWord :: Word64 -> Word64 -> Word64+deriveSeedWord leftValue rightValue =+  (leftValue * 0xff51afd7ed558ccd) `xor` (rightValue + goldenRatioConstant)
+ src-basis/Moonlight/Core/Identifier.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE RoleAnnotations #-}++-- | Validated, namespace-tagged identifier tokens ('IdentifierToken') with+-- checked and scoped constructors.+module Moonlight.Core.Identifier+  ( IdentifierToken,+    mkIdentifierToken,+    mkIdentifierTokenWith,+    mkScopedIdentifier,+    renderIdentifierToken,+    renderScopedIdentifier,+    isValidIdentifier,+  )+where++import Data.Char (isAlphaNum)+import Data.Text (Text)+import qualified Data.Text as Text+import Moonlight.Internal.Unsound (IdentifierToken (..))+import Prelude (Bool, Char, Maybe (..), fmap, not, (&&), (.), (==), (||))++mkIdentifierToken :: Text -> Maybe (IdentifierToken namespace)+mkIdentifierToken =+  mkIdentifierTokenWith isValidIdentifier++mkIdentifierTokenWith :: (Text -> Bool) -> Text -> Maybe (IdentifierToken namespace)+mkIdentifierTokenWith predicate rawInput =+  let candidate = Text.strip rawInput+   in if predicate candidate+        then Just (IdentifierToken candidate)+        else Nothing++mkScopedIdentifier :: (IdentifierToken namespace -> identifier) -> Text -> Maybe identifier+mkScopedIdentifier wrapIdentifier =+  fmap wrapIdentifier . mkIdentifierToken++renderIdentifierToken :: IdentifierToken namespace -> Text+renderIdentifierToken (IdentifierToken identifier) =+  identifier++renderScopedIdentifier :: (identifier -> IdentifierToken namespace) -> identifier -> Text+renderScopedIdentifier unwrapIdentifier =+  renderIdentifierToken . unwrapIdentifier++isValidIdentifier :: Text -> Bool+isValidIdentifier candidate =+  not (Text.null candidate) && Text.all isIdentifierCharacter candidate++isIdentifierCharacter :: Char -> Bool+isIdentifierCharacter character =+  isAlphaNum character || character == '-' || character == '_'
+ src-basis/Moonlight/Core/Identifier/EGraph.hs view
@@ -0,0 +1,74 @@+-- | Newtype identifier atoms of the e-graph vocabulary (classes, e-nodes, rules, proof steps, pattern variables): identity only, no arithmetic.+module Moonlight.Core.Identifier.EGraph+  ( ClassId (..),+    classIdKey,+    ENodeId (..),+    RegionNodeId (..),+    RewriteRuleId (..),+    ProofStepId (..),+    PatternVar,+    mkPatternVar,+    patternVarKey,+    BinderId (..),+    binderIdKey,+    rewriteRuleIdKey,+  )+where++import Data.Kind (Type)+import Moonlight.Core.DenseKey (DenseKey (..))+import Prelude (Enum, Eq, Int, Ord, Read, Show)++type ClassId :: Type+newtype ClassId = ClassId Int+  deriving stock (Eq, Ord, Show, Read)+  deriving newtype (Enum)++type ENodeId :: Type+newtype ENodeId = ENodeId Int+  deriving stock (Eq, Ord, Show, Read)+  deriving newtype (Enum)++type RegionNodeId :: Type+newtype RegionNodeId = RegionNodeId Int+  deriving stock (Eq, Ord, Show, Read)+  deriving newtype (Enum)++type RewriteRuleId :: Type+newtype RewriteRuleId = RewriteRuleId Int+  deriving stock (Eq, Ord, Show, Read)++type ProofStepId :: Type+newtype ProofStepId = ProofStepId Int+  deriving stock (Eq, Ord, Show, Read)+  deriving newtype (Enum)++type PatternVar :: Type+newtype PatternVar = PatternVar Int+  deriving stock (Eq, Ord, Show, Read)+  deriving newtype (Enum)++mkPatternVar :: Int -> PatternVar+mkPatternVar =+  PatternVar++type BinderId :: Type+newtype BinderId = BinderId Int+  deriving stock (Eq, Ord, Show, Read)+  deriving newtype (Enum)++classIdKey :: ClassId -> Int+classIdKey (ClassId key) = key++patternVarKey :: PatternVar -> Int+patternVarKey (PatternVar key) = key++binderIdKey :: BinderId -> Int+binderIdKey (BinderId key) = key++rewriteRuleIdKey :: RewriteRuleId -> Int+rewriteRuleIdKey (RewriteRuleId key) = key++instance DenseKey ClassId where+  encodeDenseKey = classIdKey+  decodeDenseKey = ClassId
+ src-basis/Moonlight/Core/IsoNorm.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FunctionalDependencies #-}++-- | The 'IsoNorm' class: a representation isomorphism @wrap@ ↔ @rep@, with+-- 'isoNormalize' canonicalising through it.+module Moonlight.Core.IsoNorm+  ( IsoNorm (..),+    isoNormalize,+  )+where++import Data.Kind (Constraint, Type)+import Prelude ((.))++type IsoNorm :: Type -> Type -> Constraint+class IsoNorm wrap rep | wrap -> rep where+  isoFrom :: rep -> wrap+  isoTo :: wrap -> rep++isoNormalize :: IsoNorm wrap rep => wrap -> wrap+isoNormalize = isoFrom . isoTo
+ src-basis/Moonlight/Core/LawName.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DerivingStrategies #-}++-- | The 'IsLawName' class and the shared 'CommonLawName' vocabulary, with+-- helpers to derive law names from constructor names.+module Moonlight.Core.LawName+  ( IsLawName (..),+    CommonLawName (..),+    constructorLawName,+    constructorLawNameWithOverrides,+  )+where++import Data.Char (isDigit, isLower, isUpper, toLower)+import Data.Kind (Constraint, Type)+import Data.Maybe (fromMaybe)+import Prelude++type IsLawName :: Type -> Constraint+class (Eq a, Ord a, Show a) => IsLawName a where+  lawNameText :: a -> String++type CommonLawName :: Type+data CommonLawName+  = LatticeAbsorptionJoin+  | LatticeAbsorptionMeet+  | NormalizeIdempotent+  deriving stock (Eq, Ord, Show)++instance IsLawName CommonLawName where+  lawNameText = constructorLawName . show++constructorLawName :: String -> String+constructorLawName = constructorLawNameWithOverrides []++constructorLawNameWithOverrides :: [(String, String)] -> String -> String+constructorLawNameWithOverrides overrides constructorName =+  fromMaybe (snakeCaseConstructorName constructorName) (lookup constructorName overrides)++snakeCaseConstructorName :: String -> String+snakeCaseConstructorName constructorName =+  case constructorName of+    [] -> []+    firstCharacter : remainingCharacters ->+      toLower firstCharacter : go firstCharacter remainingCharacters+  where+    go previousCharacter remainingCharacters =+      case remainingCharacters of+        [] -> []+        currentCharacter : nextCharacters ->+          separator previousCharacter currentCharacter nextCharacters+            ++ [toLower currentCharacter]+            ++ go currentCharacter nextCharacters++separator :: Char -> Char -> String -> String+separator previousCharacter currentCharacter nextCharacters+  | startsUpperBoundary previousCharacter currentCharacter nextCharacters = "_"+  | isDigit currentCharacter && not (isDigit previousCharacter) = "_"+  | otherwise = ""++startsUpperBoundary :: Char -> Char -> String -> Bool+startsUpperBoundary previousCharacter currentCharacter nextCharacters =+  isUpper currentCharacter+    && ((isLower previousCharacter || isDigit previousCharacter) || continuesAcronym nextCharacters)++continuesAcronym :: String -> Bool+continuesAcronym nextCharacters =+  case nextCharacters of+    nextCharacter : _ -> isLower nextCharacter+    [] -> False
+ src-basis/Moonlight/Core/MapAccum.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StrictData #-}++-- | Strict map building and accumulation helpers: indexing, grouping,+-- accumulating by key, and triple indexing.+module Moonlight.Core.MapAccum+  ( indexMap+  , groupByKey+  , accumByKey+  , buildTripleIndex+  ) where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Prelude+  ( Int+  , Ord+  , Semigroup ((<>))+  , foldl'+  , foldr+  , reverse+  , zip+  , (++)+  )++-- | Index values by zero-based input position.+--+-- Duplicate keys follow a last-occurrence-wins law: the stored index is the+-- final position at which the key appears in the input list.+indexMap :: Ord a => [a] -> Map a Int+indexMap values = Map.fromList (zip values [0 ..])++groupByKey :: Ord k => (a -> k) -> [a] -> Map k [a]+groupByKey keyOf = foldr (insertGroupedValue keyOf) Map.empty++accumByKey :: (Ord k, Semigroup v) => (a -> k) -> (a -> v) -> [a] -> Map k v+accumByKey keyOf valueOf =+  foldl'+    (\acc value -> Map.insertWith (\newValue oldValue -> oldValue <> newValue) (keyOf value) (valueOf value) acc)+    Map.empty++buildTripleIndex ::+  (Ord k1, Ord k2, Ord k3) =>+  (a -> k1) -> (a -> k2) -> (a -> k3) ->+  [a] ->+  (Map k1 [a], Map k2 [a], Map k3 [a])+buildTripleIndex keyOf1 keyOf2 keyOf3 values =+  tripleIndexAccumulatorMaps+    (foldl' (accumulateTripleIndex keyOf1 keyOf2 keyOf3) emptyTripleIndexAccumulator values)++data TripleIndexAccumulator k1 k2 k3 a+  = TripleIndexAccumulator !(Map k1 [a]) !(Map k2 [a]) !(Map k3 [a])++emptyTripleIndexAccumulator :: TripleIndexAccumulator k1 k2 k3 a+emptyTripleIndexAccumulator =+  TripleIndexAccumulator Map.empty Map.empty Map.empty++accumulateTripleIndex ::+  (Ord k1, Ord k2, Ord k3) =>+  (a -> k1) -> (a -> k2) -> (a -> k3) ->+  TripleIndexAccumulator k1 k2 k3 a ->+  a ->+  TripleIndexAccumulator k1 k2 k3 a+accumulateTripleIndex keyOf1 keyOf2 keyOf3 (TripleIndexAccumulator index1 index2 index3) value =+  TripleIndexAccumulator+    (insertGroupedValue keyOf1 value index1)+    (insertGroupedValue keyOf2 value index2)+    (insertGroupedValue keyOf3 value index3)++tripleIndexAccumulatorMaps :: TripleIndexAccumulator k1 k2 k3 a -> (Map k1 [a], Map k2 [a], Map k3 [a])+tripleIndexAccumulatorMaps (TripleIndexAccumulator index1 index2 index3) =+  (Map.map reverse index1, Map.map reverse index2, Map.map reverse index3)++insertGroupedValue :: Ord k => (a -> k) -> a -> Map k [a] -> Map k [a]+insertGroupedValue keyOf value =+  Map.insertWith (++) (keyOf value) [value]
+ src-basis/Moonlight/Core/MapInvert.hs view
@@ -0,0 +1,24 @@+-- | Transpose a set-valued map: every @(k, v)@ membership pair of @Map k (Set v)@ reappears as @(v, k)@.+module Moonlight.Core.MapInvert+  ( invertMapOfSets,+  )+where++import Control.Monad ((<=<))+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Prelude (Ord, fmap, (.))++invertMapOfSets ::+  (Ord k, Ord v) =>+  Map k (Set v) ->+  Map v (Set k)+invertMapOfSets =+  Map.fromListWith Set.union+    . (invertEntry <=< Map.toList)+  where+    invertEntry :: (sourceKey, Set targetValue) -> [(targetValue, Set sourceKey)]+    invertEntry (k, vs) =+      fmap (, Set.singleton k) (Set.toList vs)
+ src-basis/Moonlight/Core/Match.hs view
@@ -0,0 +1,43 @@+-- | Incremental-match bookkeeping: 'MatchFootprint' (the root, dependency, topo+-- and result node sets touched by a query) and 'QuerySnapshot'.+module Moonlight.Core.Match+  ( MatchFootprint (..),+    emptyFootprint,+    QuerySnapshot (..),+  )+where++import Data.Kind (Type)+import Data.IntMap.Strict (IntMap)+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Moonlight.Core.Relational (QueryId)+import Prelude++type MatchFootprint :: Type+data MatchFootprint = MatchFootprint+  { mfRoots :: !IntSet,+    mfDeps :: !IntSet,+    mfTopo :: !IntSet,+    mfResults :: !IntSet+  }+  deriving stock (Eq, Show)++emptyFootprint :: MatchFootprint+emptyFootprint =+  MatchFootprint+    { mfRoots = IntSet.empty,+      mfDeps = IntSet.empty,+      mfTopo = IntSet.empty,+      mfResults = IntSet.empty+    }++type QuerySnapshot :: Type -> Type -> Type+data QuerySnapshot projection relation = QuerySnapshot+  { baseRevision :: !Int,+    queryId :: !QueryId,+    liveEpoch :: !Int,+    liveRelations :: !(IntMap relation),+    projection :: !(IntMap projection),+    footprint :: !MatchFootprint+  }
+ src-basis/Moonlight/Core/ModuleIdentifier.hs view
@@ -0,0 +1,39 @@+-- | Predicates and splitting for qualified module names (dot-separated,+-- upper-initial segments).+module Moonlight.Core.ModuleIdentifier+  ( isQualifiedModuleName,+    isCompactName,+    isModuleSegment,+    isModuleSegmentCharacter,+    splitModuleName,+  )+where++import Data.Char (isAlphaNum, isSpace, isUpper)+import Data.Text (Text)+import qualified Data.Text as Text+import Prelude++isQualifiedModuleName :: Text -> Bool+isQualifiedModuleName candidate =+  isCompactName candidate+    && all isModuleSegment (splitModuleName candidate)++isCompactName :: Text -> Bool+isCompactName candidate =+  not (Text.null candidate) && not (Text.any isSpace candidate)++isModuleSegment :: Text -> Bool+isModuleSegment segment =+  case Text.uncons segment of+    Nothing -> False+    Just (firstCharacter, remainingCharacters) ->+      isUpper firstCharacter && Text.all isModuleSegmentCharacter remainingCharacters++isModuleSegmentCharacter :: Char -> Bool+isModuleSegmentCharacter character =+  isAlphaNum character || character == '_' || character == '\''++splitModuleName :: Text -> [Text]+splitModuleName =+  Text.splitOn (Text.pack ".")
+ src-basis/Moonlight/Core/OrdCollection.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE TypeFamilies #-}++-- | The 'OrdSet' and 'OrdMap' classes abstracting over ordered set and map+-- backends ('Data.Set'/'Data.IntSet', 'Data.Map'/'Data.IntMap').+module Moonlight.Core.OrdCollection+  ( OrdSet (..),+    OrdMap (..),+  )+where++import Data.Kind (Constraint, Type)+import Prelude (Bool, Int, Maybe, Ord)+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 (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set++type OrdSet :: Type -> Constraint+class OrdSet s where+  type SetKey s+  emptySet :: s+  nullSet :: s -> Bool+  singletonSet :: SetKey s -> s+  memberSet :: SetKey s -> s -> Bool+  unionSet :: s -> s -> s+  intersectionSet :: s -> s -> s+  differenceSet :: s -> s -> s+  unionsSet :: [s] -> s+  toAscListSet :: s -> [SetKey s]+  fromListSet :: [SetKey s] -> s+  sizeSet :: s -> Int++instance OrdSet IntSet where+  type SetKey IntSet = Int+  emptySet = IntSet.empty+  nullSet = IntSet.null+  singletonSet = IntSet.singleton+  memberSet = IntSet.member+  unionSet = IntSet.union+  intersectionSet = IntSet.intersection+  differenceSet = IntSet.difference+  unionsSet = IntSet.unions+  toAscListSet = IntSet.toAscList+  fromListSet = IntSet.fromList+  sizeSet = IntSet.size++instance Ord k => OrdSet (Set k) where+  type SetKey (Set k) = k+  emptySet = Set.empty+  nullSet = Set.null+  singletonSet = Set.singleton+  memberSet = Set.member+  unionSet = Set.union+  intersectionSet = Set.intersection+  differenceSet = Set.difference+  unionsSet = Set.unions+  toAscListSet = Set.toAscList+  fromListSet = Set.fromList+  sizeSet = Set.size++type OrdMap :: Type -> Constraint+class OrdMap m where+  type MapKey m+  type MapValue m+  emptyMap :: m+  nullMap :: m -> Bool+  lookupMap :: MapKey m -> m -> Maybe (MapValue m)+  insertMap :: MapKey m -> MapValue m -> m -> m+  insertWithMap :: (MapValue m -> MapValue m -> MapValue m) -> MapKey m -> MapValue m -> m -> m+  deleteMap :: MapKey m -> m -> m+  unionWithMap :: (MapValue m -> MapValue m -> MapValue m) -> m -> m -> m+  toAscListMap :: m -> [(MapKey m, MapValue m)]+  fromListMap :: [(MapKey m, MapValue m)] -> m+  fromListWithMap :: (MapValue m -> MapValue m -> MapValue m) -> [(MapKey m, MapValue m)] -> m+  sizeMap :: m -> Int++instance OrdMap (IntMap v) where+  type MapKey (IntMap v) = Int+  type MapValue (IntMap v) = v+  emptyMap = IntMap.empty+  nullMap = IntMap.null+  lookupMap = IntMap.lookup+  insertMap = IntMap.insert+  insertWithMap = IntMap.insertWith+  deleteMap = IntMap.delete+  unionWithMap = IntMap.unionWith+  toAscListMap = IntMap.toAscList+  fromListMap = IntMap.fromList+  fromListWithMap = IntMap.fromListWith+  sizeMap = IntMap.size++instance Ord k => OrdMap (Map k v) where+  type MapKey (Map k v) = k+  type MapValue (Map k v) = v+  emptyMap = Map.empty+  nullMap = Map.null+  lookupMap = Map.lookup+  insertMap = Map.insert+  insertWithMap = Map.insertWith+  deleteMap = Map.delete+  unionWithMap = Map.unionWith+  toAscListMap = Map.toAscList+  fromListMap = Map.fromList+  fromListWithMap = Map.fromListWith+  sizeMap = Map.size
+ src-basis/Moonlight/Core/Order.hs view
@@ -0,0 +1,124 @@+-- | The 'PartialOrder' class and helpers: comparability, and pointwise and+-- total-order orderings.+module Moonlight.Core.Order+  ( PartialOrder (..),+    comparable,+    incomparable,+    pointwiseLeqOver,+    finitePointwiseLeq,+    totalOrderLeq,+  )+where++import Data.Bool+  ( Bool (True),+    not,+    (&&),+    (||),+  )+import Data.Eq+  ( Eq,+    (/=),+  )+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet qualified as IntSet+import Data.Map.Strict qualified as Map+import Data.Ord+  ( Ord,+    (<=),+  )+import Data.Set qualified as Set+import Moonlight.Core.Finite+  ( FiniteUniverse,+    finiteUniverseList,+  )+import Numeric.Natural+  ( Natural,+  )+import Prelude+  ( Foldable,+    Int,+    Integer,+    foldr,+  )++class Eq order => PartialOrder order where+  leq :: order -> order -> Bool++  lt :: order -> order -> Bool+  lt left right =+    leq left right && left /= right++comparable :: PartialOrder order => order -> order -> Bool+comparable left right =+  leq left right || leq right left++incomparable :: PartialOrder order => order -> order -> Bool+incomparable left right =+  not (comparable left right)++pointwiseLeqOver ::+  (Foldable foldable, PartialOrder order) =>+  foldable domain ->+  (domain -> order) ->+  (domain -> order) ->+  Bool+pointwiseLeqOver domainValues left right =+  foldr+    ( \domainValue accepted ->+        leq (left domainValue) (right domainValue) && accepted+    )+    True+    domainValues++finitePointwiseLeq ::+  (FiniteUniverse domain, PartialOrder order) =>+  (domain -> order) ->+  (domain -> order) ->+  Bool+finitePointwiseLeq =+  pointwiseLeqOver finiteUniverseList++totalOrderLeq :: Ord order => order -> order -> Bool+totalOrderLeq =+  (<=)++instance PartialOrder () where+  leq _ _ =+    True++instance PartialOrder Bool where+  leq left right =+    not left || right++instance PartialOrder Int where+  leq =+    totalOrderLeq++instance PartialOrder Integer where+  leq =+    totalOrderLeq++instance PartialOrder Natural where+  leq =+    totalOrderLeq++instance Ord value => PartialOrder (Set.Set value) where+  leq =+    Set.isSubsetOf++instance PartialOrder IntSet.IntSet where+  leq =+    IntSet.isSubsetOf++instance (Ord key, PartialOrder value) => PartialOrder (Map.Map key value) where+  leq =+    Map.isSubmapOfBy leq++instance PartialOrder value => PartialOrder (IntMap.IntMap value) where+  leq =+    IntMap.isSubmapOfBy leq++instance (PartialOrder left, PartialOrder right) => PartialOrder (left, right) where+  leq (leftA, rightA) (leftB, rightB) =+    leq leftA leftB && leq rightA rightB
+ src-basis/Moonlight/Core/ProofManifest.hs view
@@ -0,0 +1,179 @@+-- | Pure JSON rendering and parsing for theorem manifests.+module Moonlight.Core.ProofManifest+  ( ProofManifestError (..),+    renderTheoremManifestJson,+    parseTheoremManifestNames,+    canonicalTheoremManifestNames,+  )+where++import Data.Char (chr, digitToInt, isHexDigit, isSpace, ord)+import Data.Kind (Type)+import Data.List (find, intercalate)+import Data.Maybe (listToMaybe)+import Data.Set qualified as Set+import Moonlight.Core.Dedup (firstDuplicate)+import Text.ParserCombinators.ReadP+  ( ReadP,+    char,+    eof,+    many,+    pfail,+    readP_to_S,+    satisfy,+    sepBy,+    skipSpaces,+    string,+    (+++),+  )+import Prelude++type ProofManifestError :: Type+data ProofManifestError+  = ProofManifestParseFailure+  | EmptyTheoremManifestName+  | WhitespacePaddedTheoremManifestName !String+  | DuplicateTheoremManifestName !String+  deriving stock (Eq, Show)++renderTheoremManifestJson :: [String] -> String+renderTheoremManifestJson theoremIdentifiers =+  "{\"theorems\":["+    <> intercalate "," (map quoteJsonString (canonicalTheoremManifestNames theoremIdentifiers))+    <> "]}"++parseTheoremManifestNames :: String -> Either ProofManifestError [String]+parseTheoremManifestNames source =+  parseManifestJson source >>= validateTheoremManifestNames++canonicalTheoremManifestNames :: [String] -> [String]+canonicalTheoremManifestNames =+  Set.toAscList . Set.fromList++trimWhitespace :: String -> String+trimWhitespace =+  dropWhile isSpace+    . reverse+    . dropWhile isSpace+    . reverse++validateTheoremManifestNames :: [String] -> Either ProofManifestError [String]+validateTheoremManifestNames theoremNames =+  case find null theoremNames of+    Just _ ->+      Left EmptyTheoremManifestName+    Nothing ->+      case find hasPadding theoremNames of+        Just theoremName ->+          Left (WhitespacePaddedTheoremManifestName theoremName)+        Nothing ->+          case duplicateTheoremName theoremNames of+            Just theoremName ->+              Left (DuplicateTheoremManifestName theoremName)+            Nothing ->+              Right theoremNames+  where+    hasPadding theoremName = trimWhitespace theoremName /= theoremName++duplicateTheoremName :: [String] -> Maybe String+duplicateTheoremName =+  firstDuplicate++parseManifestJson :: String -> Either ProofManifestError [String]+parseManifestJson source =+  case listToMaybe (reverse parses) of+    Nothing -> Left ProofManifestParseFailure+    Just (theoremNames, _) -> Right theoremNames+  where+    parses = readP_to_S (theoremManifestParser <* skipSpaces <* eof) source++theoremManifestParser :: ReadP [String]+theoremManifestParser = do+  skipSpaces+  _ <- char '{'+  skipSpaces+  _ <- string "\"theorems\""+  skipSpaces+  _ <- char ':'+  theoremNames <- jsonStringArrayParser+  skipSpaces+  _ <- char '}'+  pure theoremNames++jsonStringArrayParser :: ReadP [String]+jsonStringArrayParser = do+  skipSpaces+  _ <- char '['+  skipSpaces+  theoremNames <- sepBy jsonStringParser (skipSpaces *> char ',' <* skipSpaces)+  skipSpaces+  _ <- char ']'+  pure theoremNames++jsonStringParser :: ReadP String+jsonStringParser = do+  _ <- char '"'+  stringValue <- many jsonStringCharacterParser+  _ <- char '"'+  pure stringValue++jsonStringCharacterParser :: ReadP Char+jsonStringCharacterParser =+  escapedCharacterParser +++ satisfy jsonStringUnescapedCharacter++escapedCharacterParser :: ReadP Char+escapedCharacterParser = do+  _ <- char '\\'+  char '"'+    +++ char '\\'+    +++ char '/'+    +++ (char 'n' >> pure '\n')+    +++ (char 't' >> pure '\t')+    +++ (char 'r' >> pure '\r')+    +++ (char 'b' >> pure '\b')+    +++ (char 'f' >> pure '\f')+    +++ unicodeEscapeParser++unicodeEscapeParser :: ReadP Char+unicodeEscapeParser = do+  _ <- char 'u'+  h3 <- satisfy isHexDigit+  h2 <- satisfy isHexDigit+  h1 <- satisfy isHexDigit+  h0 <- satisfy isHexDigit+  let codePoint = digitToInt h3 * 4096 + digitToInt h2 * 256 + digitToInt h1 * 16 + digitToInt h0+  if jsonStringScalarEscape codePoint+    then pure (chr codePoint)+    else pfail++jsonStringUnescapedCharacter :: Char -> Bool+jsonStringUnescapedCharacter character =+  character /= '"' && character /= '\\' && ord character >= 0x20++jsonStringScalarEscape :: Int -> Bool+jsonStringScalarEscape codePoint =+  codePoint < 0xD800 || codePoint > 0xDFFF++quoteJsonString :: String -> String+quoteJsonString value =+  "\"" <> concatMap escapeJsonCharacter value <> "\""++escapeJsonCharacter :: Char -> String+escapeJsonCharacter '"' = "\\\""+escapeJsonCharacter '\\' = "\\\\"+escapeJsonCharacter c+  | ord c < 0x20 = "\\u" <> padHex4 (ord c)+  | otherwise = [c]++padHex4 :: Int -> String+padHex4 n =+  let d3 = n `div` 4096+      d2 = (n `mod` 4096) `div` 256+      d1 = (n `mod` 256) `div` 16+      d0 = n `mod` 16+   in fmap hexDigit [d3, d2, d1, d0]+  where+    hexDigit digit+      | digit < 10 = chr (ord '0' + digit)+      | digit < 16 = chr (ord 'a' + digit - 10)+      | otherwise = '?'
+ src-basis/Moonlight/Core/Queue.hs view
@@ -0,0 +1,49 @@+-- | A simple FIFO 'Queue' backed by 'Data.Sequence.Seq', with the usual+-- enqueue/dequeue operations.+module Moonlight.Core.Queue+  ( Queue,+    emptyQueue,+    enqueue,+    enqueueAll,+    dequeue,+    queueFromList,+    queueToList,+    queueNull,+  )+where++import Data.Bool (Bool)+import Data.Eq (Eq)+import Data.Foldable qualified as Foldable+import Data.Kind (Type)+import Data.Maybe (Maybe (..))+import Data.Sequence (Seq, (|>))+import Data.Sequence qualified as Seq+import Prelude (Show, flip, (.))++type Queue :: Type -> Type+newtype Queue a = Queue (Seq a)+  deriving stock (Eq, Show)++emptyQueue :: Queue a+emptyQueue = Queue Seq.empty++enqueue :: a -> Queue a -> Queue a+enqueue x (Queue s) = Queue (s |> x)++enqueueAll :: Foldable.Foldable t => t a -> Queue a -> Queue a+enqueueAll xs q = Foldable.foldl' (flip enqueue) q xs++dequeue :: Queue a -> Maybe (a, Queue a)+dequeue (Queue s) = case Seq.viewl s of+  Seq.EmptyL -> Nothing+  x Seq.:< rest -> Just (x, Queue rest)++queueFromList :: [a] -> Queue a+queueFromList = Queue . Seq.fromList++queueToList :: Queue a -> [a]+queueToList (Queue s) = Foldable.toList s++queueNull :: Queue a -> Bool+queueNull (Queue s) = Seq.null s
+ src-basis/Moonlight/Core/Refinement.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Predicate-indexed refinement: a 'Refined' value carries proof it passed its 'RefinementPredicate'. Checked doors live here; the unsafe one lives in "Moonlight.Core.Unsound".+module Moonlight.Core.Refinement+  ( Refined,+    RefinementPredicate (..),+    refineMaybe,+    refineEither,+    refinedValue,+    withRefined,+  )+where++import Moonlight.Core.Aggregate (note)+import Moonlight.Internal.Unsound (Refined (..))+import Data.Proxy (Proxy (..))+import Prelude (Bool, Either, Maybe (..))++class RefinementPredicate tag value where+  refinementPredicate :: Proxy tag -> value -> Bool++refineMaybe :: forall tag value. RefinementPredicate tag value => value -> Maybe (Refined tag value)+refineMaybe candidate =+  if refinementPredicate (Proxy @tag) candidate+    then Just (Refined candidate)+    else Nothing++refineEither :: RefinementPredicate tag value => errorValue -> value -> Either errorValue (Refined tag value)+refineEither errorValue candidate =+  note errorValue (refineMaybe candidate)++refinedValue :: Refined tag value -> value+refinedValue (Refined value) = value++withRefined :: Refined tag value -> (value -> result) -> result+withRefined refinedCandidate use =+  use (refinedValue refinedCandidate)
+ src-basis/Moonlight/Core/Relational.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE DerivingStrategies #-}++-- | Identifier and epoch newtypes for the relational query engine.+module Moonlight.Core.Relational+  ( QueryId,+    mkQueryId,+    queryIdKey,+    AtomId,+    mkAtomId,+    atomIdKey,+    SlotId,+    mkSlotId,+    slotIdKey,+    QuotientEpoch,+    mkQuotientEpoch,+    initialQuotientEpoch,+    quotientEpochKey,+    nextQuotientEpoch,+    LiveEpoch,+    mkLiveEpoch,+    initialLiveEpoch,+    liveEpochKey,+    nextLiveEpoch,+  )+where++import Data.Kind (Type)+import Moonlight.Core.Order+  ( PartialOrder (..),+    totalOrderLeq,+  )+import Prelude (Bounded (maxBound), Eq ((==)), Int, Num ((+)), Ord, Read, Show)++type QueryId :: Type+newtype QueryId = QueryId {unQueryId :: Int}+  deriving stock (Eq, Ord, Show, Read)++mkQueryId :: Int -> QueryId+mkQueryId =+  QueryId++queryIdKey :: QueryId -> Int+queryIdKey = unQueryId++type AtomId :: Type+newtype AtomId = AtomId {unAtomId :: Int}+  deriving stock (Eq, Ord, Show, Read)++mkAtomId :: Int -> AtomId+mkAtomId =+  AtomId++atomIdKey :: AtomId -> Int+atomIdKey = unAtomId++type SlotId :: Type+newtype SlotId = SlotId {unSlotId :: Int}+  deriving stock (Eq, Ord, Show, Read)++mkSlotId :: Int -> SlotId+mkSlotId =+  SlotId++slotIdKey :: SlotId -> Int+slotIdKey =+  unSlotId++type QuotientEpoch :: Type+newtype QuotientEpoch = QuotientEpoch {unQuotientEpoch :: Int}+  deriving stock (Eq, Ord, Show, Read)++mkQuotientEpoch :: Int -> QuotientEpoch+mkQuotientEpoch =+  QuotientEpoch++initialQuotientEpoch :: QuotientEpoch+initialQuotientEpoch =+  QuotientEpoch 0++quotientEpochKey :: QuotientEpoch -> Int+quotientEpochKey =+  unQuotientEpoch++-- | Successor epoch.  Law (monotone below ceiling): for every epoch @e@ with+-- @quotientEpochKey e < maxBound@, @nextQuotientEpoch e@ strictly increases.+-- Epochs are counters reachable by successor from 'initialQuotientEpoch'; at+-- the public constructor ceiling, successor saturates instead of overflowing.+nextQuotientEpoch :: QuotientEpoch -> QuotientEpoch+nextQuotientEpoch (QuotientEpoch epochValue) =+  QuotientEpoch (nextEpochValue epochValue)++instance PartialOrder QuotientEpoch where+  leq =+    totalOrderLeq++type LiveEpoch :: Type+newtype LiveEpoch = LiveEpoch {unLiveEpoch :: Int}+  deriving stock (Eq, Ord, Show, Read)++mkLiveEpoch :: Int -> LiveEpoch+mkLiveEpoch =+  LiveEpoch++initialLiveEpoch :: LiveEpoch+initialLiveEpoch =+  LiveEpoch 0++liveEpochKey :: LiveEpoch -> Int+liveEpochKey =+  unLiveEpoch++-- | Successor epoch.  Law (monotone below ceiling): for every epoch @e@ with+-- @liveEpochKey e < maxBound@, @nextLiveEpoch e@ strictly increases.  At the+-- public constructor ceiling, successor saturates instead of overflowing.+nextLiveEpoch :: LiveEpoch -> LiveEpoch+nextLiveEpoch (LiveEpoch epochValue) =+  LiveEpoch (nextEpochValue epochValue)++nextEpochValue :: Int -> Int+nextEpochValue epochValue =+  if epochValue == maxBound+    then maxBound+    else epochValue + 1++instance PartialOrder LiveEpoch where+  leq =+    totalOrderLeq
+ src-basis/Moonlight/Core/Scan.hs view
@@ -0,0 +1,31 @@+-- | Stateful traversal combinators: map-accumulate, monadic fold and monadic+-- unfold.+module Moonlight.Core.Scan+  ( scanMap,+    scanFoldM,+    unfoldM,+  )+where++import Control.Monad (Monad, foldM)+import Data.Foldable (Foldable)+import Data.Functor ((<$>))+import Data.Maybe (Maybe (..))+import Data.Traversable (Traversable, mapAccumL)+import Prelude (Applicative (pure))++scanMap :: Traversable container => (state -> input -> (state, output)) -> state -> container input -> (state, container output)+scanMap = mapAccumL++scanFoldM :: (Monad effect, Foldable container) => (state -> input -> effect state) -> state -> container input -> effect state+scanFoldM = foldM++unfoldM :: Monad effect => (seed -> effect (Maybe (output, seed))) -> seed -> effect [output]+unfoldM step seed =+  do+    nextStep <- step seed+    case nextStep of+      Nothing ->+        pure []+      Just (output, nextSeed) ->+        (output :) <$> unfoldM step nextSeed
+ src-basis/Moonlight/Core/StableHash.hs view
@@ -0,0 +1,639 @@+{-# LANGUAGE BangPatterns #-}++-- | Stable, deterministic structural hashing via SipHash: digests of byte+-- strings, builders, and framed byte chunks, with a default key.+--+-- The framed-chunk path ('stableHashByteStrings') folds its version-and-length+-- framing directly into an incremental SipHash-2-4 state, so no intermediate+-- lazy or strict buffer is ever materialized. The incremental core is+-- byte-for-byte identical to @memory@'s one-shot 'sipHash' over the same framed+-- byte sequence; the differential property in the test-suite is the proof, and+-- it guarantees every existing digest is preserved unchanged.+module Moonlight.Core.StableHash+  ( SipKey (..),+    SipHashState,+    StableHashEncoding,+    StableHashDigest (..),+    stableHashEncodingVersion,+    stableHashEncodingLength,+    defaultStableHashKey,+    stableHashByteString,+    stableHashBuilder,+    stableHashByteStrings,+    stableHashEncodingByteString,+    stableHashEncodingChunks,+    stableHashEncodingDigest,+    stableHashEncodingTextUtf8,+    stableHashEncodingWord8,+    stableHashEncodingWord64Dec,+    stableHashEncodingWord32LE,+    stableHashEncodingWord64LE,+    stableHashUpdateEncoding,+    sipHashDigest,+    sipHashInit,+    sipHashUpdateByteString,+    sipHashUpdateWord8,+    sipHashUpdateWord64Dec,+    sipHashUpdateWord32LE,+    sipHashUpdateWord64LE,+    sipHashFinalize,+    sipHash24,+  )+where++import Data.Bits (countLeadingZeros, finiteBitSize, rotateL, shiftL, shiftR, xor, (.&.), (.|.))+import Data.ByteArray.Hash (SipHash (..), SipKey (..), sipHash)+import qualified Data.ByteString as ByteString+import Data.ByteString (ByteString)+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Internal as ByteStringInternal+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.ByteString.Unsafe as ByteStringUnsafe+import Data.Char (ord)+import Data.Foldable (foldl')+import Data.Kind (Type)+import qualified Data.Text as Text+import qualified Data.Text.Internal as TextInternal+import Data.Word (Word32, Word64, Word8, byteSwap64)+import qualified Foreign.ForeignPtr as ForeignPtr+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (peekByteOff)+import GHC.ByteOrder (ByteOrder (..), targetByteOrder)+import GHC.Generics (Generic)+import Prelude+  ( Char,+    Eq,+    Foldable,+    IO,+    Int,+    Monoid (..),+    Ord,+    Read,+    Semigroup (..),+    Show,+    fromIntegral,+    id,+    length,+    min,+    otherwise,+    ($),+    (*),+    (+),+    (-),+    (.),+    (<),+    (>=),+    (==),+    pure,+    quot,+    rem,+  )++type StableHashDigest :: Type+newtype StableHashDigest = StableHashDigest+  { unStableHashDigest :: Word64+  }+  deriving stock (Eq, Ord, Show, Read, Generic)++defaultStableHashKey :: SipKey+defaultStableHashKey =+  SipKey 0x6d6f6f6e6c696768 0x742d636f72652d31++stableHashEncodingVersion :: Word64+stableHashEncodingVersion =+  2++sipHashDigest :: SipKey -> ByteString -> Word64+sipHashDigest key payload =+  case sipHash key payload of+    SipHash digest -> digest++stableHashByteString :: SipKey -> ByteString -> StableHashDigest+stableHashByteString key =+  StableHashDigest . sipHashDigest key++stableHashBuilder :: Builder.Builder -> StableHashDigest+stableHashBuilder payload =+  StableHashDigest+    . sipHashFinalize+    . LazyByteString.foldlChunks sipHashUpdateByteString seededState+    . Builder.toLazyByteString+    $ payload+  where+    seededState =+      sipHashUpdateWord64LE (sipHashInit defaultStableHashKey) stableHashEncodingVersion++-- | Digest a framed sequence of byte-string chunks. The version word, the+-- compact chunk count, and each compact chunk length are folded — together with+-- the chunk bytes — straight into an incremental SipHash-2-4 state. No lazy or+-- strict buffer is materialized; the result is identical to hashing the+-- concatenated framing @version ++ count ++ (length ++ bytes)*@ in one shot.+stableHashByteStrings :: Foldable chunks => chunks ByteString -> StableHashDigest+stableHashByteStrings chunks =+  StableHashDigest (sipHashFinalize (foldl' absorbChunk seededState chunks))+  where+    seededState =+      stableHashFramedChunksSeed (length chunks)+    absorbChunk state chunk =+      sipHashUpdateByteString+        (sipHashUpdateCompactWord64 state (fromIntegral (ByteString.length chunk)))+        chunk++sipHash24 :: Word64 -> Word64 -> ByteString -> Word64+sipHash24 leftKey rightKey =+  sipHashDigest (SipKey leftKey rightKey)++-- Incremental SipHash-2-4. The abstract state carries the four @v@ lanes plus+-- a 0..7-byte little-endian partial block and the running length. Absorbing+-- bytes one at a time keeps the public state immutable while deleting framed+-- buffer materialization in callers that can write directly into the digest.++type SipHashState :: Type+data SipHashState+  = SipHashState+      {-# UNPACK #-} !Word64+      {-# UNPACK #-} !Word64+      {-# UNPACK #-} !Word64+      {-# UNPACK #-} !Word64+      {-# UNPACK #-} !Word64+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int++type StableHashEncoding :: Type+data StableHashEncoding = StableHashEncoding !Int (SipHashState -> SipHashState)++type DecimalWord64Shape :: Type+data DecimalWord64Shape = DecimalWord64Shape !Int !Word64++stableHashEncodingLength :: StableHashEncoding -> Int+stableHashEncodingLength (StableHashEncoding byteLength _writer) =+  byteLength++instance Semigroup StableHashEncoding where+  StableHashEncoding leftLength leftWriter <> StableHashEncoding rightLength rightWriter =+    StableHashEncoding (leftLength + rightLength) (rightWriter . leftWriter)++instance Monoid StableHashEncoding where+  mempty =+    StableHashEncoding 0 id++sipHashInit :: SipKey -> SipHashState+sipHashInit (SipKey keyLow keyHigh) =+  SipHashState+    (keyLow `xor` 0x736f6d6570736575)+    (keyHigh `xor` 0x646f72616e646f6d)+    (keyLow `xor` 0x6c7967656e657261)+    (keyHigh `xor` 0x7465646279746573)+    0+    0+    0++sipRound ::+  Word64 ->+  Word64 ->+  Word64 ->+  Word64 ->+  (Word64, Word64, Word64, Word64)+sipRound v0 v1 v2 v3 =+  let !a0 = v0 + v1+      !a1 = rotateL v1 13 `xor` a0+      !a0' = rotateL a0 32+      !a2 = v2 + v3+      !a3 = rotateL v3 16 `xor` a2+      !b0 = a0' + a3+      !b3 = rotateL a3 21 `xor` b0+      !b2 = a2 + a1+      !b1 = rotateL a1 17 `xor` b2+      !b2' = rotateL b2 32+   in (b0, b1, b2', b3)+{-# INLINE sipRound #-}++sipCompress ::+  Word64 ->+  Word64 ->+  Word64 ->+  Word64 ->+  Word64 ->+  (Word64, Word64, Word64, Word64)+sipCompress v0 v1 v2 v3 messageWord =+  let !w3 = v3 `xor` messageWord+      (r0, r1, r2, r3) = sipRound v0 v1 v2 w3+      (s0, s1, s2, s3) = sipRound r0 r1 r2 r3+      !s0' = s0 `xor` messageWord+   in (s0', s1, s2, s3)+{-# INLINE sipCompress #-}++sipHashUpdateWord8 :: SipHashState -> Word8 -> SipHashState+sipHashUpdateWord8 (SipHashState v0 v1 v2 v3 partial partialLen total) byteValue =+  let !partial' = partial .|. (fromIntegral byteValue `shiftL` (8 * partialLen))+      !partialLen' = partialLen + 1+      !total' = total + 1+   in if partialLen' == 8+        then+          let (u0, u1, u2, u3) = sipCompress v0 v1 v2 v3 partial'+           in SipHashState u0 u1 u2 u3 0 0 total'+        else SipHashState v0 v1 v2 v3 partial' partialLen' total'+{-# INLINE sipHashUpdateWord8 #-}++sipHashUpdateByteString :: SipHashState -> ByteString -> SipHashState+sipHashUpdateByteString state chunk =+  let byteLength =+        ByteString.length chunk+   in if byteLength < 8+        then trustedSmallByteStringFold state chunk byteLength+        else+          if byteLength >= 64+            then trustedByteStringBlockFold state chunk+            else ByteString.foldl' sipHashUpdateWord8 state chunk+{-# INLINE sipHashUpdateByteString #-}++trustedSmallByteStringFold :: SipHashState -> ByteString -> Int -> SipHashState+-- Guarded small-chunk reader. The caller passes 'ByteString.length chunk', and+-- every 'unsafeIndex' below is under an exact length case. The fallback keeps+-- the helper total even if a future internal caller forgets that contract.+trustedSmallByteStringFold state chunk byteLength =+  if byteLength < 8+    then sipHashUpdateLittleEndianWord byteLength (trustedSmallByteStringWord chunk byteLength) state+    else ByteString.foldl' sipHashUpdateWord8 state chunk+{-# INLINE trustedSmallByteStringFold #-}++trustedSmallByteStringWord :: ByteString -> Int -> Word64+trustedSmallByteStringWord chunk byteLength =+  case byteLength of+    0 ->+      0+    1 ->+      fromIntegral (ByteStringUnsafe.unsafeIndex chunk 0)+    2 ->+      fromIntegral (ByteStringUnsafe.unsafeIndex chunk 0)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 1) `shiftL` 8)+    3 ->+      fromIntegral (ByteStringUnsafe.unsafeIndex chunk 0)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 1) `shiftL` 8)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 2) `shiftL` 16)+    4 ->+      fromIntegral (ByteStringUnsafe.unsafeIndex chunk 0)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 1) `shiftL` 8)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 2) `shiftL` 16)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 3) `shiftL` 24)+    5 ->+      fromIntegral (ByteStringUnsafe.unsafeIndex chunk 0)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 1) `shiftL` 8)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 2) `shiftL` 16)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 3) `shiftL` 24)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 4) `shiftL` 32)+    6 ->+      fromIntegral (ByteStringUnsafe.unsafeIndex chunk 0)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 1) `shiftL` 8)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 2) `shiftL` 16)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 3) `shiftL` 24)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 4) `shiftL` 32)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 5) `shiftL` 40)+    7 ->+      fromIntegral (ByteStringUnsafe.unsafeIndex chunk 0)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 1) `shiftL` 8)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 2) `shiftL` 16)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 3) `shiftL` 24)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 4) `shiftL` 32)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 5) `shiftL` 40)+        .|. (fromIntegral (ByteStringUnsafe.unsafeIndex chunk 6) `shiftL` 48)+    _ ->+      0+{-# INLINE trustedSmallByteStringWord #-}++-- | The sole trusted ingestion boundary in this module. 'ByteString' is+-- immutable by contract; this folds its stable foreign-ptr region directly into+-- the SipHash state, first filling any existing partial block, then consuming+-- complete 8-byte little-endian blocks, then folding the tail bytes. The public+-- API remains pure and immutable; the internal pointer read is sealed here so+-- callers cannot observe or compose the effect.+trustedByteStringBlockFold :: SipHashState -> ByteString -> SipHashState+trustedByteStringBlockFold state chunk =+  let (foreignPtr, offset, byteLength) =+        ByteStringInternal.toForeignPtr chunk+   in ByteStringInternal.accursedUnutterablePerformIO+        ( ForeignPtr.withForeignPtr foreignPtr $ \basePtr ->+            sipHashUpdatePtrRange state (basePtr `plusPtr` offset) byteLength+        )+{-# INLINE trustedByteStringBlockFold #-}++sipHashUpdatePtrRange :: SipHashState -> Ptr Word8 -> Int -> IO SipHashState+sipHashUpdatePtrRange state ptr byteLength =+  let prefixLength =+        sipHashPrefixLength state byteLength+   in do+        prefixedState <-+          sipHashUpdatePtrBytes prefixLength state ptr+        let remainingLength =+              byteLength - prefixLength+            remainingPtr =+              ptr `plusPtr` prefixLength+        sipHashUpdateAlignedPtrRange prefixedState remainingPtr remainingLength+{-# INLINE sipHashUpdatePtrRange #-}++sipHashPrefixLength :: SipHashState -> Int -> Int+sipHashPrefixLength (SipHashState _v0 _v1 _v2 _v3 _partial partialLen _total) byteLength =+  if partialLen == 0+    then 0+    else min byteLength (8 - partialLen)+{-# INLINE sipHashPrefixLength #-}++sipHashUpdateAlignedPtrRange :: SipHashState -> Ptr Word8 -> Int -> IO SipHashState+sipHashUpdateAlignedPtrRange state ptr byteLength =+  let tailLength =+        byteLength `rem` 8+      blockLength =+        byteLength - tailLength+   in do+        blockedState <-+          sipHashUpdatePtrBlocks blockLength state ptr+        sipHashUpdatePtrBytes tailLength blockedState (ptr `plusPtr` blockLength)+{-# INLINE sipHashUpdateAlignedPtrRange #-}++sipHashUpdatePtrBlocks :: Int -> SipHashState -> Ptr Word8 -> IO SipHashState+sipHashUpdatePtrBlocks byteLength state ptr =+  if byteLength == 0+    then pure state+    else do+      wordValue <-+        peekWord64LE ptr+      sipHashUpdatePtrBlocks+        (byteLength - 8)+        (sipHashUpdateAlignedWord64Block state wordValue)+        (ptr `plusPtr` 8)+{-# INLINE sipHashUpdatePtrBlocks #-}++sipHashUpdatePtrBytes :: Int -> SipHashState -> Ptr Word8 -> IO SipHashState+sipHashUpdatePtrBytes byteLength state ptr =+  if byteLength == 0+    then pure state+    else do+      byteValue <-+        peekWord8Off ptr 0+      sipHashUpdatePtrBytes+        (byteLength - 1)+        (sipHashUpdateWord8 state byteValue)+        (ptr `plusPtr` 1)+{-# INLINE sipHashUpdatePtrBytes #-}++sipHashUpdateAlignedWord64Block :: SipHashState -> Word64 -> SipHashState+sipHashUpdateAlignedWord64Block (SipHashState v0 v1 v2 v3 _partial 0 total) wordValue =+  let (u0, u1, u2, u3) =+        sipCompress v0 v1 v2 v3 wordValue+   in SipHashState u0 u1 u2 u3 0 0 (total + 8)+sipHashUpdateAlignedWord64Block state wordValue =+  sipHashUpdateWord64LE state wordValue+{-# INLINE sipHashUpdateAlignedWord64Block #-}++peekWord64LE :: Ptr Word8 -> IO Word64+peekWord64LE ptr =+  do+    nativeWord <-+      peekWord64Off ptr 0+    pure (word64FromNativeLittleEndian nativeWord)+{-# INLINE peekWord64LE #-}++word64FromNativeLittleEndian :: Word64 -> Word64+word64FromNativeLittleEndian =+  case targetByteOrder of+    LittleEndian ->+      id+    BigEndian ->+      byteSwap64+{-# INLINE word64FromNativeLittleEndian #-}++peekWord64Off :: Ptr Word8 -> Int -> IO Word64+peekWord64Off =+  peekByteOff+{-# INLINE peekWord64Off #-}++peekWord8Off :: Ptr Word8 -> Int -> IO Word8+peekWord8Off =+  peekByteOff+{-# INLINE peekWord8Off #-}++stableHashUpdateEncoding :: SipHashState -> StableHashEncoding -> SipHashState+stableHashUpdateEncoding state (StableHashEncoding _byteLength writer) =+  writer state++stableHashEncodingByteString :: ByteString -> StableHashEncoding+stableHashEncodingByteString bytes =+  StableHashEncoding (ByteString.length bytes) (`sipHashUpdateByteString` bytes)++stableHashEncodingTextUtf8 :: Text.Text -> StableHashEncoding+stableHashEncodingTextUtf8 text@(TextInternal.Text _bytes _offset byteLength) =+  StableHashEncoding byteLength (`sipHashUpdateTextUtf8` text)++sipHashUpdateTextUtf8 :: SipHashState -> Text.Text -> SipHashState+sipHashUpdateTextUtf8 =+  Text.foldl' sipHashUpdateUtf8Char++sipHashUpdateUtf8Char :: SipHashState -> Char -> SipHashState+sipHashUpdateUtf8Char state char =+  let codePoint = ord char+   in if codePoint < 0x80+        then sipHashUpdateWord8 state (fromIntegral codePoint)+        else+          if codePoint < 0x800+            then+              sipHashUpdateWord8+                (sipHashUpdateWord8 state (fromIntegral (0xc0 + (codePoint `shiftR` 6))))+                (fromIntegral (0x80 + (codePoint .&. 0x3f)))+            else+              if codePoint < 0x10000+                then+                  sipHashUpdateWord8+                    ( sipHashUpdateWord8+                        (sipHashUpdateWord8 state (fromIntegral (0xe0 + (codePoint `shiftR` 12))))+                        (fromIntegral (0x80 + ((codePoint `shiftR` 6) .&. 0x3f)))+                    )+                    (fromIntegral (0x80 + (codePoint .&. 0x3f)))+                else+                  sipHashUpdateWord8+                    ( sipHashUpdateWord8+                        ( sipHashUpdateWord8+                            (sipHashUpdateWord8 state (fromIntegral (0xf0 + (codePoint `shiftR` 18))))+                            (fromIntegral (0x80 + ((codePoint `shiftR` 12) .&. 0x3f)))+                        )+                        (fromIntegral (0x80 + ((codePoint `shiftR` 6) .&. 0x3f)))+                    )+                    (fromIntegral (0x80 + (codePoint .&. 0x3f)))++stableHashEncodingWord8 :: Word8 -> StableHashEncoding+stableHashEncodingWord8 byteValue =+  StableHashEncoding 1 (`sipHashUpdateWord8` byteValue)++stableHashEncodingWord64Dec :: Word64 -> StableHashEncoding+stableHashEncodingWord64Dec wordValue =+  case decimalWord64Shape wordValue of+    DecimalWord64Shape byteLength divisor ->+      StableHashEncoding byteLength (\state -> sipHashUpdateWord64DecWithDivisor state wordValue divisor)++sipHashUpdateWord64Dec :: SipHashState -> Word64 -> SipHashState+sipHashUpdateWord64Dec state wordValue =+  case decimalWord64Shape wordValue of+    DecimalWord64Shape _byteLength divisor ->+      sipHashUpdateWord64DecWithDivisor state wordValue divisor+{-# INLINE sipHashUpdateWord64Dec #-}++sipHashUpdateCompactWord64 :: SipHashState -> Word64 -> SipHashState+sipHashUpdateCompactWord64 state wordValue =+  let !byteValue =+        fromIntegral (wordValue .&. 0x7f)+      !remainingValue =+        wordValue `shiftR` 7+   in if remainingValue == 0+        then sipHashUpdateWord8 state byteValue+        else sipHashUpdateCompactWord64 (sipHashUpdateWord8 state (byteValue .|. 0x80)) remainingValue+{-# INLINE sipHashUpdateCompactWord64 #-}++sipHashUpdateWord64DecWithDivisor :: SipHashState -> Word64 -> Word64 -> SipHashState+sipHashUpdateWord64DecWithDivisor state wordValue divisor =+  let !digit =+        wordValue `quot` divisor+      !remainder =+        wordValue - (digit * divisor)+      !state' =+        sipHashUpdateWord8 state (fromIntegral (0x30 + digit))+   in if divisor == 1+        then state'+        else sipHashUpdateWord64DecWithDivisor state' remainder (divisor `quot` 10)+{-# INLINE sipHashUpdateWord64DecWithDivisor #-}++decimalWord64Shape :: Word64 -> DecimalWord64Shape+decimalWord64Shape wordValue =+  DecimalWord64Shape digitCount (tenToThe (digitCount - 1))+  where+    digitCount =+      decimalDigitCount wordValue+{-# INLINE decimalWord64Shape #-}++-- | The number of decimal digits of a 'Word64', in @[1, 20]@ (zero has width+-- one). Constant time: 'countLeadingZeros' gives the bit length, and+-- @bitLength * 1233 \`shiftR\` 12@ approximates @floor (logBase 10 (2 ^+-- bitLength))@ — @1233 / 4096@ is a tight rational above @logBase 10 2@ — so the+-- true width is that estimate or exactly one more, settled by a single decade+-- comparison. Proven digit-for-digit against the exact decade ladder at every+-- power-of-ten boundary.+decimalDigitCount :: Word64 -> Int+decimalDigitCount wordValue+  | wordValue == 0 = 1+  | otherwise =+      let bitLength = finiteBitSize wordValue - countLeadingZeros wordValue+          estimate = (bitLength * 1233) `shiftR` 12+       in if wordValue < tenToThe estimate then estimate else estimate + 1++-- | @10 ^ exponent@ for @exponent@ in @[0, 19]@ — every power of ten a 'Word64'+-- can hold. The search invariant only ever evaluates it inside that range; the+-- final clause supplies the @10^19@ divisor for a full-width value and keeps the+-- function total.+tenToThe :: Int -> Word64+tenToThe exponent =+  case exponent of+    0 -> 1+    1 -> 10+    2 -> 100+    3 -> 1000+    4 -> 10000+    5 -> 100000+    6 -> 1000000+    7 -> 10000000+    8 -> 100000000+    9 -> 1000000000+    10 -> 10000000000+    11 -> 100000000000+    12 -> 1000000000000+    13 -> 10000000000000+    14 -> 100000000000000+    15 -> 1000000000000000+    16 -> 10000000000000000+    17 -> 100000000000000000+    18 -> 1000000000000000000+    _ -> 10000000000000000000+{-# INLINE tenToThe #-}++sipHashUpdateWord32LE :: SipHashState -> Word32 -> SipHashState+sipHashUpdateWord32LE state word =+  sipHashUpdateLittleEndianWord 4 (fromIntegral word) state+{-# INLINE sipHashUpdateWord32LE #-}++stableHashEncodingWord32LE :: Word32 -> StableHashEncoding+stableHashEncodingWord32LE wordValue =+  StableHashEncoding 4 (`sipHashUpdateWord32LE` wordValue)++sipHashUpdateWord64LE :: SipHashState -> Word64 -> SipHashState+sipHashUpdateWord64LE state word =+  sipHashUpdateLittleEndianWord 8 word state+{-# INLINE sipHashUpdateWord64LE #-}++stableHashEncodingWord64LE :: Word64 -> StableHashEncoding+stableHashEncodingWord64LE wordValue =+  StableHashEncoding 8 (`sipHashUpdateWord64LE` wordValue)++sipHashUpdateLittleEndianWord :: Int -> Word64 -> SipHashState -> SipHashState+sipHashUpdateLittleEndianWord byteCount word (SipHashState v0 v1 v2 v3 partial partialLen total) =+  let !total' = total + byteCount+      !combinedByteCount = partialLen + byteCount+      !wordPayload = word .&. wordByteMask byteCount+   in if combinedByteCount < 8+        then+          SipHashState+            v0+            v1+            v2+            v3+            (partial .|. (wordPayload `shiftL` (8 * partialLen)))+            combinedByteCount+            total'+        else+          let !bytesToFill = 8 - partialLen+              !remainingByteCount = combinedByteCount - 8+              !messageWord =+                partial+                  .|. ((word .&. wordByteMask bytesToFill) `shiftL` (8 * partialLen))+              (u0, u1, u2, u3) = sipCompress v0 v1 v2 v3 messageWord+              !remainingPartial =+                (word `shiftR` (8 * bytesToFill)) .&. wordByteMask remainingByteCount+           in SipHashState u0 u1 u2 u3 remainingPartial remainingByteCount total'+{-# INLINE sipHashUpdateLittleEndianWord #-}++wordByteMask :: Int -> Word64+wordByteMask byteCount =+  if byteCount == 8+    then 0xffffffffffffffff+    else (1 `shiftL` (8 * byteCount)) - 1+{-# INLINE wordByteMask #-}++sipHashFinalize :: SipHashState -> Word64+sipHashFinalize (SipHashState v0 v1 v2 v3 partial _partialLen total) =+  let !finalBlock = partial .|. (fromIntegral (total .&. 0xff) `shiftL` 56)+      (w0, w1, w2, w3) = sipCompress v0 v1 v2 v3 finalBlock+      !w2' = w2 `xor` 0xff+      (f0, f1, f2, f3) = sipRound w0 w1 w2' w3+      (g0, g1, g2, g3) = sipRound f0 f1 f2 f3+      (h0, h1, h2, h3) = sipRound g0 g1 g2 g3+      (i0, i1, i2, i3) = sipRound h0 h1 h2 h3+   in i0 `xor` i1 `xor` i2 `xor` i3++stableHashEncodingDigest :: SipKey -> StableHashEncoding -> StableHashDigest+stableHashEncodingDigest key encoding =+  StableHashDigest (sipHashFinalize (stableHashUpdateEncoding (sipHashInit key) encoding))++stableHashEncodingChunks :: Foldable values => (value -> StableHashEncoding) -> values value -> StableHashDigest+stableHashEncodingChunks project values =+  StableHashDigest (sipHashFinalize (foldl' absorbChunk seededState values))+  where+    seededState =+      stableHashFramedChunksSeed (length values)+    absorbChunk state value =+      let encoding =+            project value+       in stableHashUpdateEncoding+            (sipHashUpdateCompactWord64 state (fromIntegral (stableHashEncodingLength encoding)))+            encoding++stableHashFramedChunksSeed :: Int -> SipHashState+stableHashFramedChunksSeed chunkCount =+  sipHashUpdateCompactWord64+    (sipHashUpdateWord64LE (sipHashInit defaultStableHashKey) stableHashEncodingVersion)+    (fromIntegral chunkCount)
+ src-basis/Moonlight/Core/TotalRegistry.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE RoleAnnotations #-}++-- | 'TotalRegistry', a total mapping from a finite key type to values.+-- Totality is discharged at construction: 'mkTotalRegistry' validates that+-- every key of the 'FiniteUniverse' is covered and rejects incomplete+-- coverage, so 'lookupTotal' is total for every lawful 'FiniteUniverse'+-- instance (the completeness law stated on that class). For a key outside the+-- finite universe, the result is deliberately unspecified but non-crashing.+module Moonlight.Core.TotalRegistry+  ( TotalRegistry,+    mkTotalRegistry,+    lookupTotal,+  )+where++import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Moonlight.Core.Finite (FiniteUniverse (..))+import Moonlight.Core.Validation (Validation (..), validationToEither)+import Prelude++type TotalRegistry :: Type -> Type -> Type+data TotalRegistry key value = TotalRegistry !(Map key value) !value+type role TotalRegistry nominal representational++mkTotalRegistry :: (FiniteUniverse key, Ord key) => Map key value -> Either [key] (TotalRegistry key value)+mkTotalRegistry entries =+  case validationToEither (traverse (lookupFiniteEntry entries) finiteUniverse) of+    Left missingKeys ->+      Left missingKeys+    Right validatedEntries@((_firstKey, firstValue) :| _rest) ->+      Right (TotalRegistry (Map.fromList (NonEmpty.toList validatedEntries)) firstValue)++lookupFiniteEntry :: Ord key => Map key value -> key -> Validation [key] (key, value)+lookupFiniteEntry entries key =+  case Map.lookup key entries of+    Nothing ->+      Invalid [key]+    Just value ->+      Valid (key, value)++lookupTotal :: Ord key => TotalRegistry key value -> key -> value+lookupTotal (TotalRegistry entries fallbackValue) key =+  Map.findWithDefault fallbackValue key entries
+ src-basis/Moonlight/Core/TypeLevel.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE NoStarIsType #-}++module Moonlight.Core.TypeLevel+  ( type (+),+    type (*),+    type (<=),+    SNat (..),+  )+where++import Data.Kind (Type)+import GHC.TypeNats (KnownNat, Nat, type (*), type (+), type (<=))++type SNat :: Nat -> Type+data SNat (n :: Nat) where+  SNat :: (KnownNat n) => SNat n
+ src-basis/Moonlight/Core/Validation.hs view
@@ -0,0 +1,67 @@+-- | Error-accumulating counterpart of 'Either': 'collectEither' gathers every failure instead of stopping at the first.+module Moonlight.Core.Validation+  ( Validation (..),+    eitherToValidation,+    validationToEither,+    mapValidationError,+    collectEither,+  )+where++import Data.Kind (Type)+import Prelude+  ( Applicative (..),+    Either (..),+    Eq,+    Functor (..),+    Semigroup ((<>)),+    Show,+    Traversable (traverse),+  )++type Validation :: Type -> Type -> Type+data Validation err value+  = Invalid err+  | Valid value+  deriving stock (Eq, Show)++instance Functor (Validation err) where+  fmap mapper validationValue =+    case validationValue of+      Invalid err -> Invalid err+      Valid value -> Valid (mapper value)++instance Semigroup err => Applicative (Validation err) where+  pure = Valid+  validationFunction <*> validationValue =+    case (validationFunction, validationValue) of+      (Valid mapper, Valid value) -> Valid (mapper value)+      (Invalid leftErr, Invalid rightErr) -> Invalid (leftErr <> rightErr)+      (Invalid err, Valid _) -> Invalid err+      (Valid _, Invalid err) -> Invalid err++eitherToValidation :: Either err value -> Validation err value+eitherToValidation eitherValue =+  case eitherValue of+    Left err -> Invalid err+    Right value -> Valid value++validationToEither :: Validation err value -> Either err value+validationToEither validationValue =+  case validationValue of+    Invalid err -> Left err+    Valid value -> Right value++mapValidationError ::+  (leftErr -> rightErr) ->+  Validation leftErr value ->+  Validation rightErr value+mapValidationError transform validationValue =+  case validationValue of+    Invalid err -> Invalid (transform err)+    Valid value -> Valid value++collectEither :: Semigroup err => [Either err value] -> Either err [value]+collectEither eitherValues =+  validationToEither+    (traverse eitherToValidation eitherValues)
+ src-basis/Moonlight/Internal/Unsound.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RoleAnnotations #-}++module Moonlight.Internal.Unsound+  ( TrustJustification (..),+    Refined (..),+    unsafelyTrustRefined,+    IdentifierToken (..),+    unsafelyTrustIdentifierToken,+  )+where++import Data.Kind (Type)+import Data.Text (Text)+import qualified Data.Text as Text+import Prelude (Eq, Ord, Read, Show, seq)++type TrustJustification :: Type+data TrustJustification+  = CarrierContractCanonicalLiteral+  | CanonicalObservationBoundary+  deriving stock (Eq, Ord, Show, Read)++type Refined :: forall kindValue. kindValue -> Type -> Type+newtype Refined tag value = Refined value+  deriving stock (Eq, Ord, Show)++type role Refined nominal nominal++unsafelyTrustRefined :: TrustJustification -> value -> Refined tag value+unsafelyTrustRefined justification value =+  justification `seq` Refined value++type IdentifierToken :: forall namespaceKind. namespaceKind -> Type+newtype IdentifierToken namespace = IdentifierToken Text+  deriving stock (Eq, Ord, Show)++type role IdentifierToken nominal++unsafelyTrustIdentifierToken :: TrustJustification -> Text -> IdentifierToken namespace+unsafelyTrustIdentifierToken trustJustification rawInput =+  trustJustification `seq` IdentifierToken (Text.strip rawInput)
+ src-egraph-program/Moonlight/Core/EGraph/Program.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE RankNTypes #-}++module Moonlight.Core.EGraph.Program+  ( EGraphProgramOp (..),+    EGraphProgram,+    EGraphProgramEffect,+    emptyEGraphProgramEffect,+    repeatEGraphProgramEffect,+    insertedFreshNodeEffect,+    requiredClassMergeEffect,+    eGraphProgramEffectCount,+    eGraphProgramChanged,+    insertedFreshNode,+    eGraphProgramRequiredClassMerge,+    foldEGraphProgram,+    abortProgram,+    canonicalizeClass,+    canonicalizeClasses,+    addNode,+    addCanonicalNode,+    mergeClasses,+    mergeCanonicalClasses,+  )+where++import Control.Monad.Free (Free (..), foldFree)+import Data.Kind (Type)+import Data.Monoid (Any (..), Sum (..))+import Data.Semigroup (stimes)+import GHC.Generics (Generic, Generically (..))+import Moonlight.Core.Identifier.EGraph (ClassId)+import Prelude+  ( Bool (..),+    Eq,+    Functor,+    Int,+    Monad,+    Monoid,+    Ord,+    Semigroup,+    Show,+    Traversable,+    mempty,+    traverse,+    (<=),+    (>>=),+    (>),+    (.),+  )++-- | Host-neutral e-graph program instruction.+--+-- This is the tiny algebra every equality-saturation backend must implement:+-- canonicalize class identifiers, insert e-nodes, stage class merges for host+-- rebuild/repair, or abort with a typed obstruction. Rewrite compilers emit+-- this language; e-graph hosts interpret it.+type EGraphProgramOp :: Type -> Type -> Type -> Type+data EGraphProgramOp programError node next+  = CanonicalizeClass !ClassId (ClassId -> next)+  | AddNode !node (ClassId -> next)+  | MergeClasses !ClassId !ClassId (ClassId -> next)+  | AbortProgram !programError+  deriving stock (Functor)++type EGraphProgram :: Type -> Type -> Type -> Type+type EGraphProgram programError node resultValue =+  Free (EGraphProgramOp programError node) resultValue++type EGraphProgramEffect :: Type+data EGraphProgramEffect = EGraphProgramEffect+  { egpeEffectiveApplications :: !(Sum Int),+    insertedFreshNode :: !Any,+    egpeRequiredClassMerge :: !Any+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving (Semigroup, Monoid) via (Generically EGraphProgramEffect)++emptyEGraphProgramEffect :: EGraphProgramEffect+emptyEGraphProgramEffect =+  mempty++repeatEGraphProgramEffect :: Int -> EGraphProgramEffect -> EGraphProgramEffect+repeatEGraphProgramEffect count effectValue =+  if count <= 0+    then emptyEGraphProgramEffect+    else stimes count effectValue+{-# INLINE repeatEGraphProgramEffect #-}++insertedFreshNodeEffect :: EGraphProgramEffect+insertedFreshNodeEffect =+  EGraphProgramEffect+    { egpeEffectiveApplications = Sum 1,+      insertedFreshNode = Any True,+      egpeRequiredClassMerge = mempty+    }++requiredClassMergeEffect :: EGraphProgramEffect+requiredClassMergeEffect =+  EGraphProgramEffect+    { egpeEffectiveApplications = Sum 1,+      insertedFreshNode = mempty,+      egpeRequiredClassMerge = Any True+    }++eGraphProgramEffectCount :: EGraphProgramEffect -> Int+eGraphProgramEffectCount EGraphProgramEffect {egpeEffectiveApplications = count} =+  getSum count++eGraphProgramChanged :: EGraphProgramEffect -> Bool+eGraphProgramChanged =+  (> 0) . eGraphProgramEffectCount++insertedFreshNode :: EGraphProgramEffect -> Bool+insertedFreshNode EGraphProgramEffect {insertedFreshNode = inserted} =+  getAny inserted++eGraphProgramRequiredClassMerge :: EGraphProgramEffect -> Bool+eGraphProgramRequiredClassMerge EGraphProgramEffect {egpeRequiredClassMerge = required} =+  getAny required++foldEGraphProgram ::+  Monad m =>+  (forall next. EGraphProgramOp programError node next -> m next) ->+  EGraphProgram programError node resultValue ->+  m resultValue+foldEGraphProgram =+  foldFree++abortProgram ::+  programError ->+  EGraphProgram programError node resultValue+abortProgram =+  Free . AbortProgram++canonicalizeClass ::+  ClassId ->+  EGraphProgram programError node ClassId+canonicalizeClass classId =+  Free (CanonicalizeClass classId Pure)++canonicalizeClasses ::+  Traversable t =>+  t ClassId ->+  EGraphProgram programError node (t ClassId)+canonicalizeClasses =+  traverse canonicalizeClass++addNode ::+  node ->+  EGraphProgram programError node ClassId+addNode node =+  Free (AddNode node Pure)++addCanonicalNode ::+  Traversable f =>+  f ClassId ->+  EGraphProgram programError (f ClassId) ClassId+addCanonicalNode node = do+  canonicalNode <- canonicalizeClasses node+  addNode canonicalNode >>= canonicalizeClass++mergeClasses ::+  ClassId ->+  ClassId ->+  EGraphProgram programError node ClassId+mergeClasses leftClassId rightClassId =+  Free (MergeClasses leftClassId rightClassId Pure)++mergeCanonicalClasses ::+  ClassId ->+  ClassId ->+  EGraphProgram programError node ClassId+mergeCanonicalClasses leftClassId rightClassId = do+  canonicalLeftClassId <- canonicalizeClass leftClassId+  canonicalRightClassId <- canonicalizeClass rightClassId+  mergeClasses canonicalLeftClassId canonicalRightClassId
+ src-numeric/Moonlight/Core/ApproxEq.hs view
@@ -0,0 +1,247 @@+module Moonlight.Core.ApproxEq+  ( AbsTol,+    mkAbsTol,+    absTol,+    absTolValue,+    RelTol,+    mkRelTol,+    relTol,+    relTolValue,+    UlpTol,+    mkUlpTol,+    ulpTolValue,+    Tolerance (..),+    normalizeTolerance,+    withinToleranceBy,+    ApproxEq (..),+    withinTol,+  )+where++import Data.Kind (Constraint, Type)+import qualified Data.Set as Set+import Data.Word (Word64)+import Moonlight.Core.Canon (mkNonNegativeFiniteDouble)+import Moonlight.Core.Error (MoonlightError)+import Moonlight.Internal.FloatMath (ulpDistance, ulpDistanceFloat)+import Prelude++type AbsTol :: Type+-- | Non-negative finite absolute tolerance.+newtype AbsTol = AbsTol Double+  deriving stock (Eq, Ord, Show)++mkAbsTol :: Double -> Either MoonlightError AbsTol+mkAbsTol = fmap AbsTol . mkNonNegativeFiniteDouble "absolute tolerance"++absTol :: Double -> Either MoonlightError AbsTol+absTol = mkAbsTol++absTolValue :: AbsTol -> Double+absTolValue (AbsTol value) = value++type RelTol :: Type+-- | Non-negative finite relative tolerance.+newtype RelTol = RelTol Double+  deriving stock (Eq, Ord, Show)++mkRelTol :: Double -> Either MoonlightError RelTol+mkRelTol = fmap RelTol . mkNonNegativeFiniteDouble "relative tolerance"++relTol :: Double -> Either MoonlightError RelTol+relTol = mkRelTol++relTolValue :: RelTol -> Double+relTolValue (RelTol value) = value++type UlpTol :: Type+-- | Unsigned ULP-distance tolerance.+newtype UlpTol = UlpTol Word64+  deriving stock (Eq, Ord, Show)++mkUlpTol :: Word64 -> UlpTol+mkUlpTol = UlpTol++ulpTolValue :: UlpTol -> Word64+ulpTolValue (UlpTol value) = value++type Tolerance :: Type+-- | Composite tolerance expression.+--+-- 'CompositeTol' is conjunction (meet) and 'DisjunctiveTol' is disjunction+-- (join) in the implication order over the instance's valid comparison domain.+-- 'Exact' is the bottom element of that order: @Exact /\ t = Exact@ and+-- @Exact \/ t = t@ whenever @t@ obeys the 'ApproxEq' reflexivity law on the+-- valid comparison domain.+data Tolerance+  = Exact+  | AbsTolBound !AbsTol+  | RelTolBound !RelTol+  | UlpTolBound !UlpTol+  | CompositeTol !Tolerance !Tolerance+  | DisjunctiveTol !Tolerance !Tolerance+  deriving stock (Eq, Ord, Show)++-- | Put a 'Tolerance' expression into canonical algebraic normal form.+--+-- The normal form recursively flattens associative 'CompositeTol' and+-- 'DisjunctiveTol' nests, sorts and deduplicates branches by structural order,+-- rebuilds multi-branch expressions as left-associated chains, collapses+-- @Exact /\ t@ to 'Exact', and drops 'Exact' from disjunctions as the bottom+-- element of the implication order.+normalizeTolerance :: Tolerance -> Tolerance+normalizeTolerance toleranceValue =+  case toleranceValue of+    Exact -> Exact+    AbsTolBound value -> AbsTolBound value+    RelTolBound value -> RelTolBound value+    UlpTolBound value -> UlpTolBound value+    CompositeTol leftTolerance rightTolerance ->+      normalizeCompositeTolerance+        ( compositeToleranceBranches (normalizeTolerance leftTolerance)+            <> compositeToleranceBranches (normalizeTolerance rightTolerance)+        )+    DisjunctiveTol leftTolerance rightTolerance ->+      normalizeDisjunctiveTolerance+        ( disjunctiveToleranceBranches (normalizeTolerance leftTolerance)+            <> disjunctiveToleranceBranches (normalizeTolerance rightTolerance)+        )++normalizeCompositeTolerance :: [Tolerance] -> Tolerance+normalizeCompositeTolerance branches+  | any (== Exact) branches = Exact+  | otherwise = rebuildCompositeTolerance (canonicalToleranceBranches branches)++normalizeDisjunctiveTolerance :: [Tolerance] -> Tolerance+normalizeDisjunctiveTolerance =+  rebuildDisjunctiveTolerance . canonicalToleranceBranches . filter (/= Exact)++compositeToleranceBranches :: Tolerance -> [Tolerance]+compositeToleranceBranches toleranceValue =+  case toleranceValue of+    CompositeTol leftTolerance rightTolerance ->+      compositeToleranceBranches leftTolerance <> compositeToleranceBranches rightTolerance+    branch ->+      [branch]++disjunctiveToleranceBranches :: Tolerance -> [Tolerance]+disjunctiveToleranceBranches toleranceValue =+  case toleranceValue of+    DisjunctiveTol leftTolerance rightTolerance ->+      disjunctiveToleranceBranches leftTolerance <> disjunctiveToleranceBranches rightTolerance+    branch ->+      [branch]++canonicalToleranceBranches :: [Tolerance] -> [Tolerance]+canonicalToleranceBranches =+  Set.toAscList . Set.fromList++rebuildCompositeTolerance :: [Tolerance] -> Tolerance+rebuildCompositeTolerance branches =+  case branches of+    [] -> Exact+    firstBranch : remainingBranches ->+      foldl' CompositeTol firstBranch remainingBranches++rebuildDisjunctiveTolerance :: [Tolerance] -> Tolerance+rebuildDisjunctiveTolerance branches =+  case branches of+    [] -> Exact+    firstBranch : remainingBranches ->+      foldl' DisjunctiveTol firstBranch remainingBranches++withinToleranceBy ::+  Eq a =>+  (a -> a -> Double) ->+  (a -> a -> Double) ->+  (UlpTol -> a -> a -> Bool) ->+  Tolerance ->+  a ->+  a ->+  Bool+withinToleranceBy distance scale withinUlp toleranceValue leftValue rightValue =+  case toleranceValue of+    Exact ->+      leftValue == rightValue+    AbsTolBound absoluteTolerance ->+      distance leftValue rightValue <= absTolValue absoluteTolerance+    RelTolBound relativeTolerance ->+      distance leftValue rightValue <= relTolValue relativeTolerance * scale leftValue rightValue+    UlpTolBound ulpTolerance ->+      withinUlp ulpTolerance leftValue rightValue+    CompositeTol leftTolerance rightTolerance ->+      withinToleranceBy distance scale withinUlp leftTolerance leftValue rightValue+        && withinToleranceBy distance scale withinUlp rightTolerance leftValue rightValue+    DisjunctiveTol leftTolerance rightTolerance ->+      withinToleranceBy distance scale withinUlp leftTolerance leftValue rightValue+        || withinToleranceBy distance scale withinUlp rightTolerance leftValue rightValue++type ApproxEq :: Type -> Type -> Constraint+-- | Approximate equality under a tolerance value.+--+-- Each instance has a /valid comparison domain/: the subset of the carrier+-- on which the laws below are required. For IEEE floating-point carriers+-- ('Double', 'Float') the valid comparison domain is the non-NaN values;+-- comparisons involving NaN are outside the domain and must return 'False'.+-- For exact carriers the domain is the whole type.+--+-- Laws over the instance's valid comparison domain:+--+-- [Reflexivity] @approxEq tol x x@+--+-- [Symmetry] @approxEq tol x y = approxEq tol y x@+--+-- [Tolerance monotonicity] for tolerance families with a widening order, widening a tolerance must not turn a successful comparison into a failure.+class ApproxEq tol a where+  -- | Compare two values under the supplied tolerance.+  approxEq :: tol -> a -> a -> Bool++withinTol :: (ApproxEq tol a) => tol -> a -> a -> Bool+withinTol = approxEq+++instance ApproxEq AbsTol Double where+  approxEq tolerance x y+    | x == y = True+    | isNaN x || isNaN y = False+    | isInfinite x || isInfinite y = False+    | otherwise = abs (x - y) <= absTolValue tolerance++instance ApproxEq RelTol Double where+  approxEq tolerance x y+    | x == y = True+    | isNaN x || isNaN y = False+    | isInfinite x || isInfinite y = False+    | otherwise =+        let d = abs (x - y)+            s = max (abs x) (abs y)+         in d <= relTolValue tolerance * s++instance ApproxEq UlpTol Double where+  approxEq tolerance x y+    | x == y = True+    | isNaN x || isNaN y = False+    | otherwise = ulpDistance x y <= ulpTolValue tolerance++instance ApproxEq AbsTol Float where+  approxEq tolerance x y+    | x == y = True+    | isNaN x || isNaN y = False+    | isInfinite x || isInfinite y = False+    | otherwise = abs (realToFrac x - realToFrac y) <= absTolValue tolerance++instance ApproxEq RelTol Float where+  approxEq tolerance x y+    | x == y = True+    | isNaN x || isNaN y = False+    | isInfinite x || isInfinite y = False+    | otherwise =+        let d = abs (realToFrac x - realToFrac y) :: Double+            s = max (abs (realToFrac x)) (abs (realToFrac y)) :: Double+         in d <= relTolValue tolerance * s++instance ApproxEq UlpTol Float where+  approxEq tolerance x y+    | x == y = True+    | isNaN x || isNaN y = False+    | otherwise = ulpDistanceFloat x y <= ulpTolValue tolerance
+ src-numeric/Moonlight/Core/Canon.hs view
@@ -0,0 +1,109 @@+-- | Checked constructors for canonical floating point ('mkFiniteDouble' and friends) and the hash-stable quantization they share.+module Moonlight.Core.Canon+  ( canonicalize+  , isCanonical+  , quantizeForHash+  , mkFiniteDouble+  , mkFiniteWith+  , mkPositiveInt+  , mkPositiveIntWith+  , mkPositiveFiniteDouble+  , mkPositiveFiniteWith+  , mkNonNegativeFiniteDouble+  , mkNonNegativeFiniteWith+  ) where++import Data.Int (Int64)+import Data.Word (Word32)+import Moonlight.Core.Error (MoonlightError (..), MoonlightErrorContext (..), NonFiniteInput (..))+import Moonlight.Internal.FloatMath (isNegativeZero, normalizeNegativeZero)+import Prelude+  ( Bool(..), Bounded(..), Double, Either(..), Int, Num(..), Ord(..)+  , Integer, String, fromIntegral, id, isInfinite, isNaN, not, otherwise+  , round, toInteger, (&&), (^), (>>=)+  )++canonicalize :: Double -> Either MoonlightError Double+canonicalize x+  | isNaN x = Left (NonFiniteValue CanonicalizeContext NaNInput)+  | isInfinite x = Left (NonFiniteValue CanonicalizeContext InfiniteInput)+  | otherwise = Right (normalizeNegativeZero x)++isCanonical :: Double -> Bool+isCanonical x = not (isNaN x) && not (isInfinite x) && not (isNegativeZero x)++quantizeForHash :: Word32 -> Double -> Either MoonlightError Int64+quantizeForHash precision value+  | precision > 9     = Left (QuantizePrecisionTooLarge precision)+  | isNaN value       = Left (NonFiniteValue QuantizeContext NaNInput)+  | isInfinite value  = Left (NonFiniteValue QuantizeContext InfiniteInput)+  | otherwise =+      let scale = (10 :: Double) ^ (fromIntegral precision :: Int)+          scaled = value * scale+      in if scaled >= fromIntegral (maxBound :: Int64)+           then Right maxBound+           else+             if scaled <= fromIntegral (minBound :: Int64)+               then Right minBound+               else Right (saturate (round scaled :: Integer))+  where+    saturate :: Integer -> Int64+    saturate q+      | q > toInteger (maxBound :: Int64) = maxBound+      | q < toInteger (minBound :: Int64) = minBound+      | otherwise = fromIntegral q++mkFiniteDouble :: String -> Double -> Either MoonlightError Double+mkFiniteDouble domainLabel value+  | isNaN value = Left (NonFiniteValue (DomainContext domainLabel) NaNInput)+  | isInfinite value = Left (NonFiniteValue (DomainContext domainLabel) InfiniteInput)+  | otherwise = Right (normalizeNegativeZero value)++mkFiniteWith :: (Double -> errorValue) -> (Double -> value) -> Double -> Either errorValue value+mkFiniteWith errorValue wrapValue value =+  case canonicalize value of+    Left _ -> Left (errorValue value)+    Right canonicalValue -> Right (wrapValue canonicalValue)++mkPositiveInt :: String -> Int -> Either MoonlightError Int+mkPositiveInt domainLabel =+  mkPositiveIntWith+    (\_ -> NonPositiveValue (DomainContext domainLabel))+    id++mkPositiveIntWith :: (Int -> errorValue) -> (Int -> value) -> Int -> Either errorValue value+mkPositiveIntWith errorValue wrapValue value+  | value <= 0 = Left (errorValue value)+  | otherwise = Right (wrapValue value)++mkPositiveFiniteDouble :: String -> Double -> Either MoonlightError Double+mkPositiveFiniteDouble domainLabel value =+  mkFiniteDouble domainLabel value >>= \finiteValue ->+    if finiteValue <= 0+      then Left (NonPositiveValue (DomainContext domainLabel))+      else Right finiteValue++mkPositiveFiniteWith :: (Double -> errorValue) -> (Double -> value) -> Double -> Either errorValue value+mkPositiveFiniteWith errorValue wrapValue value =+  case mkFiniteWith errorValue id value of+    Left validationError -> Left validationError+    Right finiteValue ->+      if finiteValue <= 0+        then Left (errorValue value)+        else Right (wrapValue finiteValue)++mkNonNegativeFiniteDouble :: String -> Double -> Either MoonlightError Double+mkNonNegativeFiniteDouble domainLabel value =+  mkFiniteDouble domainLabel value >>= \finiteValue ->+    if finiteValue < 0+      then Left (NegativeValue (DomainContext domainLabel))+      else Right finiteValue++mkNonNegativeFiniteWith :: (Double -> errorValue) -> (Double -> value) -> Double -> Either errorValue value+mkNonNegativeFiniteWith errorValue wrapValue value =+  case mkFiniteWith errorValue id value of+    Left validationError -> Left validationError+    Right finiteValue ->+      if finiteValue < 0+        then Left (errorValue value)+        else Right (wrapValue finiteValue)
+ src-numeric/Moonlight/Core/CanonicalNumber.hs view
@@ -0,0 +1,20 @@+module Moonlight.Core.CanonicalNumber+  ( CanonicalNumber (..),+    CanonicalFiniteValue,+    mkCanonicalFiniteValue,+    mkCanonicalFiniteNumber,+    canonicalFiniteValue,+    canonicalNumberFromDouble,+    canonicalNumberToMaybeDouble,+  )+where++import Moonlight.Core.CanonicalNumber.Internal+  ( CanonicalFiniteValue,+    CanonicalNumber (..),+    canonicalFiniteValue,+    canonicalNumberFromDouble,+    canonicalNumberToMaybeDouble,+    mkCanonicalFiniteNumber,+    mkCanonicalFiniteValue,+  )
+ src-numeric/Moonlight/Core/CanonicalNumber/Internal.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Moonlight.Core.CanonicalNumber.Internal+  ( CanonicalNumber (..),+    CanonicalFiniteValue,+    unsafeCanonicalFiniteAssumeCanonical,+    unsafeCanonicalFiniteLiteral,+    mkCanonicalFiniteValue,+    mkCanonicalFiniteNumber,+    canonicalFiniteValue,+    canonicalNumberFromDouble,+    canonicalNumberToMaybeDouble,+  )+where++import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import GHC.Generics (Generic)+import Moonlight.Core.Canon (canonicalize, isCanonical)+import Moonlight.Core.Error (MoonlightError (..))+import Moonlight.Core.Refinement+  ( Refined,+    RefinementPredicate (..),+    refineEither,+    refinedValue,+  )+import Moonlight.Internal.FloatMath (normalizeNegativeZero)+import Moonlight.Internal.Unsound (TrustJustification (..), unsafelyTrustRefined)+import Prelude+  ( Double,+    Either (..),+    Eq,+    Int,+    Maybe (..),+    Ord (..),+    Show,+    compare,+    fmap,+    isInfinite,+    isNaN,+    otherwise,+    (&&),+    (<),+    ($),+    (.),+    (>>=),+  )++type CanonicalFiniteTag :: Type+data CanonicalFiniteTag++instance RefinementPredicate CanonicalFiniteTag Double where+  refinementPredicate Proxy =+    isCanonical++type CanonicalFiniteValue :: Type+-- | Finite canonical 'Double' value.+--+-- Invariant: the contained value is finite, is accepted by 'isCanonical',+-- has passed 'canonicalize', and therefore contains no NaN, no infinity, and+-- no negative zero.+newtype CanonicalFiniteValue = CanonicalFiniteValue (Refined CanonicalFiniteTag Double)+  deriving stock (Eq, Ord, Show, Generic)++type CanonicalNumber :: Type+-- | Canonical numeric domain with finite canonical values and explicit infinities+-- plus an explicit NaN inhabitant.+data CanonicalNumber+  = CanonicalFinite CanonicalFiniteValue+  | NegInf+  | PosInf+  | NaN+  deriving stock (Eq, Show, Generic)++instance Ord CanonicalNumber where+  compare leftValue rightValue =+    compare (canonicalNumberOrderKey leftValue) (canonicalNumberOrderKey rightValue)++unsafeCanonicalFiniteLiteral :: Double -> CanonicalFiniteValue+unsafeCanonicalFiniteLiteral =+  unsafeCanonicalFiniteWith CarrierContractCanonicalLiteral++unsafeCanonicalFiniteAssumeCanonical :: Double -> CanonicalFiniteValue+unsafeCanonicalFiniteAssumeCanonical =+  unsafeCanonicalFiniteWith CanonicalObservationBoundary++unsafeCanonicalFiniteWith :: TrustJustification -> Double -> CanonicalFiniteValue+unsafeCanonicalFiniteWith justification rawValue =+  CanonicalFiniteValue+    (unsafelyTrustRefined justification (normalizeNegativeZero rawValue))++mkCanonicalFiniteValue :: Double -> Either MoonlightError CanonicalFiniteValue+mkCanonicalFiniteValue rawValue =+  fmap CanonicalFiniteValue $+    canonicalize rawValue+      >>= refineEither NonCanonicalFiniteValue++mkCanonicalFiniteNumber :: Double -> Either MoonlightError CanonicalNumber+mkCanonicalFiniteNumber =+  fmap CanonicalFinite . mkCanonicalFiniteValue++canonicalFiniteValue :: CanonicalFiniteValue -> Double+canonicalFiniteValue (CanonicalFiniteValue refinedCanonical) =+  refinedValue refinedCanonical++canonicalNumberFromDouble :: Double -> CanonicalNumber+canonicalNumberFromDouble rawValue+  | isNaN rawValue = NaN+  | isInfinite rawValue && rawValue < 0 = NegInf+  | isInfinite rawValue = PosInf+  | otherwise =+      case mkCanonicalFiniteValue rawValue of+        Right finiteValue -> CanonicalFinite finiteValue+        Left _ -> NaN++canonicalNumberToMaybeDouble :: CanonicalNumber -> Maybe Double+canonicalNumberToMaybeDouble canonicalNumber =+  case canonicalNumber of+    CanonicalFinite finiteValue -> Just (canonicalFiniteValue finiteValue)+    PosInf -> Nothing+    NegInf -> Nothing+    NaN -> Nothing++canonicalNumberOrderKey :: CanonicalNumber -> (Int, Maybe Double)+canonicalNumberOrderKey canonicalNumber =+  case canonicalNumber of+    NegInf -> (0, Nothing)+    CanonicalFinite finiteValue -> (1, Just (canonicalFiniteValue finiteValue))+    PosInf -> (2, Nothing)+    NaN -> (3, Nothing)
+ src-numeric/Moonlight/Core/ExactToken.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UnboxedTuples #-}++-- | Self-delimiting byte encodings of exact values: an 'ExactToken' is the canonical serialized witness used for structural identity.+module Moonlight.Core.ExactToken+  ( ExactToken,+    ExactEncoding,+    ExactEncodingAtom (..),+    ExactEncodingError (..),+    exactTokenFromEncoding,+    exactTokenBytes,+    exactTokenLength,+    exactEncodingLength,+    exactAtomEncoding,+    exactSequenceEncoding,+    exactSequenceMapEncoding,+  )+where++import Data.Bits (shiftR)+import Data.ByteString.Short.Internal (ShortByteString (SBS))+import Data.ByteString.Short.Internal qualified as ShortByteString+import Data.Foldable (foldr)+import Data.Int (Int64)+import Data.Kind (Type)+import Data.Word (Word64)+import GHC.Exts+  ( Int (I#),+    Int#,+    MutableByteArray#,+    State#,+    newByteArray#,+    unsafeFreezeByteArray#,+    writeWord8Array#,+    (<#),+    (+#),+  )+import GHC.ST (ST (..), runST)+import GHC.Word (Word8 (W8#))+import Prelude+  ( Bool (False),+    Either (..),+    Eq (..),+    Foldable,+    Ord (..),+    Ordering (GT, LT),+    Show (..),+    fromIntegral,+    id,+    (<>),+  )++type ExactToken :: Type+data ExactToken+  = CompactExactToken !ShortByteString+  | OversizedExactToken ExactStructure++instance Eq ExactToken where+  left == right =+    case (left, right) of+      (CompactExactToken leftBytes, CompactExactToken rightBytes) -> leftBytes == rightBytes+      (OversizedExactToken leftStructure, OversizedExactToken rightStructure) -> leftStructure == rightStructure+      _ -> False++instance Ord ExactToken where+  compare left right =+    case (left, right) of+      (CompactExactToken leftBytes, CompactExactToken rightBytes) -> compare leftBytes rightBytes+      (OversizedExactToken leftStructure, OversizedExactToken rightStructure) -> compare leftStructure rightStructure+      (CompactExactToken _, OversizedExactToken _) -> LT+      (OversizedExactToken _, CompactExactToken _) -> GT++instance Show ExactToken where+  show token =+    case token of+      CompactExactToken bytes -> "ExactToken " <> show bytes+      OversizedExactToken structure -> "OversizedExactToken " <> show structure++type ExactEncoding :: Type+data ExactEncoding = ExactEncoding ExactStructure {-# UNPACK #-} !ExactLength ExactEncodingWriter++type ExactStructure :: Type+data ExactStructure+  = ExactAtomStructure !ExactEncodingAtom+  | ExactSequenceStructure [ExactStructure]+  deriving stock (Eq, Ord, Show)++type ExactLength :: Type+data ExactLength+  = ValidExactLength Int#+  | ExactLengthOverflow++type ExactEncodingAtom :: Type+data ExactEncodingAtom+  = ExactWord8 Word8+  | ExactInt Int+  deriving stock (Eq, Ord, Show)++type ExactEncodingError :: Type+data ExactEncodingError+  = ExactEncodingLengthExceedsPlatformLimit+  deriving stock (Eq, Show)++exactTokenFromEncoding :: ExactEncoding -> ExactToken+exactTokenFromEncoding (ExactEncoding structure byteLength writer) =+  case byteLength of+    ValidExactLength validByteLength ->+      CompactExactToken (sealExactEncoding# validByteLength writer)+    ExactLengthOverflow ->+      OversizedExactToken structure++exactTokenBytes :: ExactToken -> Either ExactEncodingError ShortByteString+exactTokenBytes token =+  case token of+    CompactExactToken bytes -> Right bytes+    OversizedExactToken _structure -> Left ExactEncodingLengthExceedsPlatformLimit++exactTokenLength :: ExactToken -> Either ExactEncodingError Int+exactTokenLength token =+  case token of+    CompactExactToken bytes -> Right (ShortByteString.length bytes)+    OversizedExactToken _structure -> Left ExactEncodingLengthExceedsPlatformLimit++exactEncodingLength :: ExactEncoding -> Either ExactEncodingError Int+exactEncodingLength (ExactEncoding _structure byteLength _writer) =+  case byteLength of+    ValidExactLength validByteLength -> Right (I# validByteLength)+    ExactLengthOverflow -> Left ExactEncodingLengthExceedsPlatformLimit++exactAtomEncoding :: ExactEncodingAtom -> ExactEncoding+exactAtomEncoding atom =+  case atom of+    ExactWord8 byteValue ->+      ExactEncoding+        (ExactAtomStructure atom)+        (ValidExactLength 2#)+        (writeExactWord8 0x01 `appendExactEncodingWriter` writeExactWord8 byteValue)+    ExactInt intValue ->+      ExactEncoding+        (ExactAtomStructure atom)+        (ValidExactLength 9#)+        (writeExactWord8 0x02 `appendExactEncodingWriter` exactInt64BEWriter intValue)+{-# INLINE exactAtomEncoding #-}++-- The grammar is prefix-decodable: atoms have fixed payload widths, while+-- 0x03 and 0x04 delimit a sequence. Recursive decoding therefore determines+-- every child boundary without redundant per-child lengths.+exactSequenceEncoding :: Foldable values => values ExactEncoding -> ExactEncoding+exactSequenceEncoding =+  exactSequenceMapEncoding id+{-# INLINE exactSequenceEncoding #-}++exactSequenceMapEncoding :: Foldable values => (value -> ExactEncoding) -> values value -> ExactEncoding+exactSequenceMapEncoding project values =+  let SequenceEncoding childByteLength childWriter =+        foldr+          (\value suffix -> prependSequenceEncoding (project value) suffix)+          emptySequenceEncoding+          values+   in ExactEncoding+        ( ExactSequenceStructure+            (foldr (\value suffix -> exactEncodingStructure (project value) : suffix) [] values)+        )+        (checkedLengthAdd (ValidExactLength 2#) childByteLength)+        ( writeExactWord8 0x03+            `appendExactEncodingWriter` childWriter+            `appendExactEncodingWriter` writeExactWord8 0x04+        )+{-# INLINE exactSequenceMapEncoding #-}++type SequenceEncoding :: Type+data SequenceEncoding = SequenceEncoding {-# UNPACK #-} !ExactLength ExactEncodingWriter++emptySequenceEncoding :: SequenceEncoding+emptySequenceEncoding =+  SequenceEncoding (ValidExactLength 0#) emptyExactEncodingWriter++prependSequenceEncoding :: ExactEncoding -> SequenceEncoding -> SequenceEncoding+prependSequenceEncoding (ExactEncoding _structure childByteLength childWriter) (SequenceEncoding suffixByteLength suffixWriter) =+  SequenceEncoding+    (checkedLengthAdd childByteLength suffixByteLength)+    (appendExactEncodingWriter childWriter suffixWriter)+{-# INLINE prependSequenceEncoding #-}++exactEncodingStructure :: ExactEncoding -> ExactStructure+exactEncodingStructure (ExactEncoding structure _byteLength _writer) =+  structure++checkedLengthAdd :: ExactLength -> ExactLength -> ExactLength+checkedLengthAdd left right =+  case (left, right) of+    (ValidExactLength leftValue#, ValidExactLength rightValue#) ->+      case leftValue# +# rightValue# of+        sumValue# ->+          case sumValue# <# 0# of+            0# -> ValidExactLength sumValue#+            _ -> ExactLengthOverflow+    _ -> ExactLengthOverflow+{-# INLINE checkedLengthAdd #-}++exactInt64BEWriter :: Int -> ExactEncodingWriter+exactInt64BEWriter intValue =+  writeExactWord64BE (fromIntegral (fromIntegral intValue :: Int64))++sealExactEncoding# :: Int# -> ExactEncodingWriter -> ShortByteString+sealExactEncoding# byteLength# writer =+  runST (ST createExactTokenBytes)+  where+    createExactTokenBytes :: State# s -> (# State# s, ShortByteString #)+    createExactTokenBytes state0 =+      case newByteArray# byteLength# state0 of+        (# state1, mutableBytes #) ->+          case writer mutableBytes 0# state1 of+            (# state2, _endOffset #) ->+              case unsafeFreezeByteArray# mutableBytes state2 of+                (# state3, frozenBytes #) -> (# state3, SBS frozenBytes #)++type ExactEncodingWriter :: Type+type ExactEncodingWriter =+  forall s.+  MutableByteArray# s ->+  Int# ->+  State# s ->+  (# State# s, Int# #)++appendExactEncodingWriter :: ExactEncodingWriter -> ExactEncodingWriter -> ExactEncodingWriter+appendExactEncodingWriter leftWriter rightWriter mutableBytes offset state0 =+  case leftWriter mutableBytes offset state0 of+    (# state1, offset1 #) -> rightWriter mutableBytes offset1 state1++emptyExactEncodingWriter :: ExactEncodingWriter+emptyExactEncodingWriter _mutableBytes offset state =+  (# state, offset #)++writeExactWord64BE :: Word64 -> ExactEncodingWriter+writeExactWord64BE wordValue =+  writeExactWord8 (fromIntegral (wordValue `shiftR` 56))+    `appendExactEncodingWriter` writeExactWord8 (fromIntegral (wordValue `shiftR` 48))+    `appendExactEncodingWriter` writeExactWord8 (fromIntegral (wordValue `shiftR` 40))+    `appendExactEncodingWriter` writeExactWord8 (fromIntegral (wordValue `shiftR` 32))+    `appendExactEncodingWriter` writeExactWord8 (fromIntegral (wordValue `shiftR` 24))+    `appendExactEncodingWriter` writeExactWord8 (fromIntegral (wordValue `shiftR` 16))+    `appendExactEncodingWriter` writeExactWord8 (fromIntegral (wordValue `shiftR` 8))+    `appendExactEncodingWriter` writeExactWord8 (fromIntegral wordValue)++writeExactWord8 :: Word8 -> ExactEncodingWriter+writeExactWord8 (W8# byteValue) mutableBytes offset state0 =+  case writeWord8Array# mutableBytes offset byteValue state0 of+    state1 -> (# state1, offset +# 1# #)
+ src-numeric/Moonlight/Core/Niche.hs view
@@ -0,0 +1,31 @@+-- | Checked niche vocabulary: topographic samples ('TopoSample') and stressor sets, validated at construction.+module Moonlight.Core.Niche+  ( NicheValidationError (..),+    TopoSample,+    mkTopoSample,+    flatTopoSample,+    topoSlope,+    topoAspect,+    topoCurvature,+    StressorId,+    mkStressorId,+    renderStressorId,+    defaultStressorId,+    ActiveStressor,+    mkActiveStressor,+    activeStressorId,+    activeStressorIntensity,+    ActiveStressorSet,+    emptyActiveStressorSet,+    activeStressorSetFromList,+    activeStressorSetEntries,+    activeStressorSetTopEntries,+    ContextSignature,+    emptyContextSignature,+    mkContextSignature,+    contextSignatureBins,+  )+where++import Moonlight.Core.Niche.Internal+
+ src-numeric/Moonlight/Core/Niche/Internal.hs view
@@ -0,0 +1,216 @@+module Moonlight.Core.Niche.Internal+  ( NicheValidationError (..),+    TopoSample,+    mkTopoSample,+    flatTopoSample,+    topoSlope,+    topoAspect,+    topoCurvature,+    StressorId,+    mkStressorId,+    unsafeTrustStressorId,+    renderStressorId,+    defaultStressorId,+    ActiveStressor,+    mkActiveStressor,+    activeStressorId,+    activeStressorIntensity,+    ActiveStressorSet,+    emptyActiveStressorSet,+    activeStressorSetFromList,+    activeStressorSetEntries,+    activeStressorSetTopEntries,+    ContextSignature,+    emptyContextSignature,+    mkContextSignature,+    contextSignatureBins,+  )+where++import Data.Bifunctor (first)+import Data.Kind (Type)+import Data.List (genericTake, sortBy)+import qualified Data.Map.Strict as Map+import Data.Ord (Down (..), comparing)+import Data.Text (Text, pack)+import Data.Text qualified as Text+import Data.Word (Word32)+import Moonlight.Core.Canon (canonicalize)+import Moonlight.Core.Error (MoonlightError)+import Moonlight.Core.Identifier+  ( IdentifierToken,+    mkScopedIdentifier,+    renderIdentifierToken,+  )+import Moonlight.Internal.Unsound (TrustJustification, unsafelyTrustIdentifierToken)+import Numeric.Natural (Natural)+import Prelude+  ( Bool (..),+    Double,+    Either (..),+    Eq,+    Maybe (..),+    Ord,+    Show,+    compare,+    map,+    max,+    otherwise,+    pure,+    uncurry,+    (.),+    (==),+    (>),+    (>=),+  )++type NicheValidationError :: Type+data NicheValidationError+  = NicheCanonicalScalarRejected !MoonlightError+  | NegativeTopoSlope !Double+  | NonPositiveStressorIntensity !Double+  deriving stock (Eq, Show)++type TopoSample :: Type+data TopoSample = TopoSample+  { topoSlope :: Double,+    topoAspect :: Double,+    topoCurvature :: Double+  }+  deriving stock (Eq, Show)++mkTopoSample :: Double -> Double -> Double -> Either NicheValidationError TopoSample+mkTopoSample slopeValue aspectValue curvatureValue = do+  canonicalSlope <- canonicalizeScalar slopeValue+  canonicalAspect <- canonicalizeScalar aspectValue+  canonicalCurvature <- canonicalizeScalar curvatureValue+  if canonicalSlope >= 0.0+    then pure (TopoSample canonicalSlope canonicalAspect canonicalCurvature)+    else Left (NegativeTopoSlope canonicalSlope)++flatTopoSample :: TopoSample+flatTopoSample = TopoSample 0.0 0.0 0.0++type StressorIdNamespace :: Type+data StressorIdNamespace++type StressorId :: Type+data StressorId+  = DefaultStressorId+  | StressorId !(IdentifierToken StressorIdNamespace)+  deriving stock (Show)++instance Eq StressorId where+  left == right =+    case (left, right) of+      (DefaultStressorId, DefaultStressorId) ->+        True+      (StressorId leftToken, StressorId rightToken) ->+        leftToken == rightToken+      _ ->+        renderStressorId left == renderStressorId right++instance Ord StressorId where+  compare left right =+    case (left, right) of+      (DefaultStressorId, DefaultStressorId) ->+        compare (renderStressorId left) (renderStressorId right)+      (StressorId leftToken, StressorId rightToken) ->+        compare leftToken rightToken+      _ ->+        compare (renderStressorId left) (renderStressorId right)++mkStressorId :: Text -> Maybe StressorId+mkStressorId rawInput+  | Text.strip rawInput == defaultStressorIdText =+      Just DefaultStressorId+  | otherwise =+      mkScopedIdentifier StressorId rawInput++unsafeTrustStressorId :: TrustJustification -> Text -> StressorId+unsafeTrustStressorId justification rawInput+  | Text.strip rawInput == defaultStressorIdText =+      DefaultStressorId+  | otherwise =+      StressorId (unsafelyTrustIdentifierToken justification rawInput)++renderStressorId :: StressorId -> Text+renderStressorId stressorId =+  case stressorId of+    DefaultStressorId ->+      defaultStressorIdText+    StressorId identifierToken ->+      renderIdentifierToken identifierToken++defaultStressorId :: StressorId+defaultStressorId =+  defaultStressorIdFrom (mkStressorId defaultStressorIdText)++defaultStressorIdText :: Text+defaultStressorIdText =+  pack "default"++defaultStressorIdFrom :: Maybe StressorId -> StressorId+defaultStressorIdFrom maybeStressorId =+  case maybeStressorId of+    Just stressorId -> stressorId+    Nothing -> DefaultStressorId++type ActiveStressor :: Type+data ActiveStressor = ActiveStressor+  { activeStressorId :: StressorId,+    activeStressorIntensity :: Double+  }+  deriving stock (Eq, Show)++mkActiveStressor :: StressorId -> Double -> Either NicheValidationError ActiveStressor+mkActiveStressor stressorId intensityValue = do+  canonicalIntensity <- canonicalizeScalar intensityValue+  if canonicalIntensity > 0.0+    then pure (ActiveStressor stressorId canonicalIntensity)+    else Left (NonPositiveStressorIntensity canonicalIntensity)++type ActiveStressorSet :: Type+newtype ActiveStressorSet = ActiveStressorSet [ActiveStressor]+  deriving stock (Eq, Show)++emptyActiveStressorSet :: ActiveStressorSet+emptyActiveStressorSet = ActiveStressorSet []++activeStressorSetFromList :: [ActiveStressor] -> ActiveStressorSet+activeStressorSetFromList stressors =+  ActiveStressorSet+    ( sortBy canonicalOrder+        ( map (uncurry ActiveStressor)+            (Map.toList (Map.fromListWith max (map stressorEntry stressors)))+        )+    )+  where+    stressorEntry stressor =+      (activeStressorId stressor, activeStressorIntensity stressor)+    canonicalOrder =+      comparing+        (\stressor -> (Down (activeStressorIntensity stressor), activeStressorId stressor))++activeStressorSetEntries :: ActiveStressorSet -> [ActiveStressor]+activeStressorSetEntries (ActiveStressorSet stressors) = stressors++activeStressorSetTopEntries :: Natural -> ActiveStressorSet -> [ActiveStressor]+activeStressorSetTopEntries limit =+  genericTake limit . activeStressorSetEntries++type ContextSignature :: Type+newtype ContextSignature = ContextSignature [Word32]+  deriving stock (Eq, Ord, Show)++emptyContextSignature :: ContextSignature+emptyContextSignature = ContextSignature []++mkContextSignature :: [Word32] -> ContextSignature+mkContextSignature = ContextSignature++contextSignatureBins :: ContextSignature -> [Word32]+contextSignatureBins (ContextSignature bins) = bins++canonicalizeScalar :: Double -> Either NicheValidationError Double+canonicalizeScalar = first NicheCanonicalScalarRejected . canonicalize
+ src-numeric/Moonlight/Core/Numeric.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TypeFamilies #-}++-- | Aggregate aliases of the scalar tower: 'OrderedRing', 'OrderedField', and 'ContinuousField' (an ordered field whose magnitude is its own carrier).+module Moonlight.Core.Numeric+  ( OrderedRing,+    OrderedField,+    ContinuousField,+  )+where++import Data.Kind (Constraint, Type)+import Data.Type.Equality (type (~))+import Moonlight.Core.Scalar (Field, Magnitude, Metric, Ring)+import Prelude (Double, Float, Int, Integer, Ord)++type OrderedRing :: Type -> Constraint+class (Ring a, Ord a) => OrderedRing a++type OrderedField :: Type -> Constraint+class (OrderedRing a, Field a) => OrderedField a++type ContinuousField :: Type -> Constraint+class (OrderedField a, Metric a, Magnitude a ~ a) => ContinuousField a++instance OrderedRing Int++instance OrderedRing Integer++instance OrderedRing Double++instance OrderedField Double++instance ContinuousField Double++instance OrderedRing Float++instance OrderedField Float++instance ContinuousField Float
+ src-numeric/Moonlight/Core/Scalar.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies #-}++module Moonlight.Core.Scalar+  ( AdditiveMonoid (..),+    AdditiveGroup (..),+    MultiplicativeMonoid (..),+    Semiring,+    Ring,+    CommutativeRing,+    Field (..),+    requireInvertible,+    Metric (..),+  )+where++import Data.Kind (Constraint, Type)+import Data.Maybe (isJust)+import Data.Type.Equality (type (~))+import Prelude+  ( Bool (..),+    Double,+    Either (..),+    Float,+    Fractional ((/)),+    Int,+    Integer,+    Maybe (..),+    Num (..),+    Rational,+    RealFloat,+    fmap,+    isInfinite,+    isNaN,+    not,+    otherwise,+    (&&),+    (||),+    (.),+    (==),+  )++type AdditiveMonoid :: Type -> Constraint+-- | Additive monoid structure for scalar carriers.+--+-- Laws hold exactly for exact carriers ('Int', 'Integer', 'Rational',+-- 'Bool'). For IEEE floating-point carriers ('Double', 'Float') the+-- identity laws hold on non-NaN values, while associativity and+-- distributivity hold only up to rounding; this qualification applies+-- to every law block in this module that is instantiated at a+-- floating-point carrier.+--+-- Laws:+--+-- [Left identity] @add zero x = x@+--+-- [Right identity] @add x zero = x@+--+-- [Associativity] @add (add x y) z = add x (add y z)@+class AdditiveMonoid a where+  -- | Additive identity.+  zero :: a+  default zero :: Num a => a+  zero = 0++  -- | Additive composition.+  add :: a -> a -> a+  default add :: Num a => a -> a -> a+  add = (+)++type AdditiveGroup :: Type -> Constraint+-- | Additive group structure extending 'AdditiveMonoid'.+--+-- Laws:+--+-- [Left inverse] @add (neg x) x = zero@+--+-- [Right inverse] @add x (neg x) = zero@+--+-- [Involution] @neg (neg x) = x@+--+-- [Subtraction] @sub x y = add x (neg y)@+class AdditiveMonoid a => AdditiveGroup a where+  -- | Additive inverse.+  neg :: a -> a+  default neg :: Num a => a -> a+  neg = negate++  -- | Subtraction as addition of the inverse.+  sub :: a -> a -> a+  sub x y = x `add` neg y++type MultiplicativeMonoid :: Type -> Constraint+-- | Multiplicative monoid structure for scalar carriers.+--+-- Laws:+--+-- [Left identity] @mul one x = x@+--+-- [Right identity] @mul x one = x@+--+-- [Associativity] @mul (mul x y) z = mul x (mul y z)@+class MultiplicativeMonoid a where+  -- | Multiplicative identity.+  one :: a+  default one :: Num a => a+  one = 1++  -- | Multiplicative composition.+  mul :: a -> a -> a+  default mul :: Num a => a -> a -> a+  mul = (*)++type Semiring :: Type -> Constraint+-- | Semiring structure over additive and multiplicative monoids.+--+-- Laws:+--+-- [Additive commutativity] @add x y = add y x@+--+-- [Left distributivity] @mul x (add y z) = add (mul x y) (mul x z)@+--+-- [Right distributivity] @mul (add y z) x = add (mul y x) (mul z x)@+class (AdditiveMonoid a, MultiplicativeMonoid a) => Semiring a++type Ring :: Type -> Constraint+-- | Ring structure: a semiring whose additive structure is a group.+class (Semiring a, AdditiveGroup a) => Ring a++type CommutativeRing :: Type -> Constraint+-- | Commutative ring structure.+--+-- Law:+--+-- [Multiplicative commutativity] @mul x y = mul y x@+class Ring a => CommutativeRing a++type Field :: Type -> Constraint+-- | Partial field interface for scalar carriers.+--+-- Laws over values satisfying 'fieldValueValid':+--+-- [Zero rejection] @tryInv zero = Nothing@+--+-- [Inverse identity] for invertible @x@, @tryInv x = Just y@ implies @mul x y = one@+--+-- [Division] @tryDiv x y = fmap (mul x) (tryInv y)@+--+-- [Division by one] @tryDiv x one = Just x@+--+-- [Division by zero] @tryDiv x zero = Nothing@+--+-- [Invertibility predicate] @canInvert x = isJust (tryInv x)@+class (Ring a) => Field a where+  -- | Attempt to produce a multiplicative inverse.+  tryInv :: a -> Maybe a++  -- | Attempt division by multiplying by the inverse of the divisor.+  tryDiv :: a -> a -> Maybe a+  tryDiv x y = fmap (mul x) (tryInv y)++  -- | Whether 'tryInv' succeeds.+  canInvert :: a -> Bool+  canInvert = isJust . tryInv++  -- | Domain predicate for values on which field laws are required.+  fieldValueValid :: a -> Bool+  fieldValueValid _ = True++requireInvertible :: Field a => errorValue -> a -> Either errorValue a+requireInvertible errorValue value =+  case tryInv value of+    Just inverseValue -> Right inverseValue+    Nothing -> Left errorValue++type Metric :: Type -> Constraint+-- | Magnitude projection for scalar carriers.+--+-- Laws:+--+-- [Zero magnitude] @magnitude zero = zero@+--+-- [Negation invariance] @magnitude (neg x) = magnitude x@+--+-- [Non-negativity] ordered magnitudes that can represent absolute values satisfy @magnitude x >= zero@.+class Metric a where+  type Magnitude a :: Type+  -- | Project a scalar into its magnitude carrier.+  magnitude :: a -> Magnitude a+  default magnitude :: (Num a, Magnitude a ~ a) => a -> Magnitude a+  magnitude = abs++instance AdditiveMonoid Bool where+  zero = False+  add = (||)++instance MultiplicativeMonoid Bool where+  one = True+  mul = (&&)++instance Semiring Bool++instance AdditiveMonoid Int++instance AdditiveGroup Int where+  sub = (-)++instance MultiplicativeMonoid Int++instance Semiring Int++instance Ring Int++instance Metric Int where+  type Magnitude Int = Int++instance AdditiveMonoid Integer++instance AdditiveGroup Integer where+  sub = (-)++instance MultiplicativeMonoid Integer++instance Semiring Integer++instance Ring Integer++instance CommutativeRing Integer++instance Metric Integer where+  type Magnitude Integer = Integer++instance AdditiveMonoid Double++instance AdditiveGroup Double where+  sub = (-)++instance MultiplicativeMonoid Double++instance Semiring Double++instance Ring Double++instance CommutativeRing Double++instance Field Double where+  tryInv = ieeeTryInv+  fieldValueValid = ieeeFieldValueValid++instance Metric Double where+  type Magnitude Double = Double++instance AdditiveMonoid Float++instance AdditiveGroup Float where+  sub = (-)++instance MultiplicativeMonoid Float++instance Semiring Float++instance Ring Float++instance CommutativeRing Float++instance Field Float where+  tryInv = ieeeTryInv+  fieldValueValid = ieeeFieldValueValid++instance Metric Float where+  type Magnitude Float = Float++ieeeTryInv :: RealFloat scalar => scalar -> Maybe scalar+ieeeTryInv value+  | not (ieeeFieldValueValid value) = Nothing+  | value == 0 = Nothing+  | not (ieeeFieldValueValid inverse) = Nothing+  | otherwise = Just inverse+  where+    inverse = 1 / value+{-# INLINE ieeeTryInv #-}++ieeeFieldValueValid :: RealFloat scalar => scalar -> Bool+ieeeFieldValueValid value =+  not (isNaN value) && not (isInfinite value)+{-# INLINE ieeeFieldValueValid #-}++instance AdditiveMonoid Rational++instance AdditiveGroup Rational where+  sub = (-)++instance MultiplicativeMonoid Rational++instance Semiring Rational++instance Ring Rational++instance CommutativeRing Rational++instance Field Rational where+  tryInv value+    | value == zero = Nothing+    | otherwise = Just (1 / value)
+ src-numeric/Moonlight/Core/Unsound.hs view
@@ -0,0 +1,18 @@+-- | The opt-in trust boundary: unsafe constructors that mint refined values,+-- identifier tokens and canonical numbers from a 'TrustJustification' rather than+-- a runtime check. Import deliberately.+module Moonlight.Core.Unsound+  ( TrustJustification (..),+    unsafelyTrustRefined,+    unsafelyTrustIdentifierToken,+    unsafeTrustDomainId,+    unsafeTrustStressorId,+    unsafeCanonicalFiniteLiteral,+    unsafeCanonicalFiniteAssumeCanonical,+  )+where++import Moonlight.Core.CanonicalNumber.Internal (unsafeCanonicalFiniteLiteral, unsafeCanonicalFiniteAssumeCanonical)+import Moonlight.Core.DomainId.Internal (unsafeTrustDomainId)+import Moonlight.Core.Niche.Internal (unsafeTrustStressorId)+import Moonlight.Internal.Unsound (TrustJustification (..), unsafelyTrustIdentifierToken, unsafelyTrustRefined)
+ src-numeric/Moonlight/Internal/FloatMath.hs view
@@ -0,0 +1,83 @@+-- | Floating-point normalization helpers.+--+-- 'ulpDistance' and 'ulpDistanceFloat' map IEEE bit patterns into monotone+-- unsigned order keys before subtracting. The chosen key law collapses the two+-- IEEE zeros to the same key, so their distance is zero, while adjacent+-- distinct representable values have distance one. If either operand is NaN,+-- the distance is the sentinel @0xFFFFFFFFFFFFFFFF@.+module Moonlight.Internal.FloatMath+  ( ulpDistance,+    ulpDistanceFloat,+    isNegativeZero,+    normalizeNegativeZero,+  )+where++import Data.Bits ((.&.), complement)+import Data.Word (Word32, Word64)+import GHC.Float (castDoubleToWord64, castFloatToWord32)+import Prelude (Bool, Double, Eq (..), Float, Num (..), Ord (..), fromIntegral, otherwise, (||))++doubleSignBit :: Word64+doubleSignBit = 0x8000000000000000++doubleZeroKey :: Word64+doubleZeroKey = doubleSignBit - 1++floatSignBit :: Word32+floatSignBit = 0x80000000++floatZeroKey :: Word32+floatZeroKey = floatSignBit - 1++-- | Detect IEEE negative zero by inspecting the sign bit pattern directly.+isNegativeZero :: Double -> Bool+isNegativeZero x = castDoubleToWord64 x == doubleSignBit++-- | Rewrite negative zero to positive zero and leave all other values intact.+normalizeNegativeZero :: Double -> Double+normalizeNegativeZero x+  | isNegativeZero x = 0.0+  | otherwise = x++doubleOrderKey :: Double -> Word64+doubleOrderKey x =+  let bits = castDoubleToWord64 x+   in if bits .&. doubleSignBit == doubleSignBit+        then complement bits+        else bits + doubleZeroKey++floatOrderKey :: Float -> Word32+floatOrderKey x =+  let bits = castFloatToWord32 x+   in if bits .&. floatSignBit == floatSignBit+        then complement bits+        else bits + floatZeroKey++-- | ULP distance between two 'Double' values after monotonic-bias reinterpretation.+--+-- Returns @0xFFFFFFFFFFFFFFFF@ when either input is NaN.+ulpDistance :: Double -> Double -> Word64+ulpDistance a b+  | a /= a || b /= b = 0xFFFFFFFFFFFFFFFF+  | otherwise =+      let leftKey = doubleOrderKey a+          rightKey = doubleOrderKey b+       in if leftKey >= rightKey+            then leftKey - rightKey+            else rightKey - leftKey++-- | ULP distance between two 'Float' values in the native 32-bit key lattice.+--+-- Returns @0xFFFFFFFFFFFFFFFF@ when either input is NaN.+ulpDistanceFloat :: Float -> Float -> Word64+ulpDistanceFloat a b+  | a /= a || b /= b = 0xFFFFFFFFFFFFFFFF+  | otherwise =+      let leftKey = floatOrderKey a+          rightKey = floatOrderKey b+       in fromIntegral+            ( if leftKey >= rightKey+                then leftKey - rightKey+                else rightKey - leftKey+            )
+ src-public/Moonlight/Core.hs view
@@ -0,0 +1,136 @@+{-|+Authoritative frozen umbrella re-export of the moonlight-core foundation+surface. Direct @Moonlight.Core.*@ module imports outside this module are+internal-use-at-own-risk, except for the deliberately explicit+"Moonlight.Core.Unsound" trust boundary. Unsafe refinement constructors are not+re-exported here.+-}+module Moonlight.Core+  ( -- * Numeric tower+    module ScalarX,+    module NumericX,+    module ApproxEqX,+    -- * Canonical and exact numbers+    module CanonX,+    module CanonicalNumberX,+    module ExactTokenX,+    -- * Validation, refinement and niches+    module ValidationX,+    module RefinementX,+    module NicheX,+    -- * Type-level utilities+    module TypeLevelX,+    -- * Identifiers, domains, capabilities and language+    module DomainIdX,+    PatternVar,+    mkPatternVar,+    module IdentifierX,+    module IdentifierEGraphX,+    module CapabilityX,+    module LanguageX,+    module ModuleIdentifierX,+    -- * Theories and patterns+    module TheoryX,+    module PatternX,+    module MatchX,+    module SubstitutionX,+    -- * Errors+    module ErrorX,+    -- * Hashing+    module StableHashX,+    module HashX,+    module DenseKeyX,+    -- * Finiteness, order and fixpoints+    module FiniteX,+    module OrderX,+    module OrdCollectionX,+    module FixOrderX,+    module FixpointX,+    module FixpointDenseX,+    -- * Maps, registries, queues and normalization+    module AggregateX,+    module BoundaryX,+    module CardinalityX,+    module DedupX,+    module GuidanceX,+    module LawNameX,+    module MapAccumX,+    module MapInvertX,+    module ProofManifestX,+    module QueueX,+    module RelationalX,+    module ScanX,+    module EGraphProgramX,+    module SiteProgramX,+    module TermDatabaseX,+    module TermDatabaseCanonicalizeX,+    module TotalRegistryX,+    module UnionFindX,+    module UnionFindTransactionX,+    module IsoNormX,+  )+where++import Moonlight.Core.Aggregate as AggregateX+import Moonlight.Core.ApproxEq as ApproxEqX+import Moonlight.Core.Boundary as BoundaryX+import Moonlight.Core.Cardinality as CardinalityX+import Moonlight.Core.Canon as CanonX+import Moonlight.Core.CanonicalNumber as CanonicalNumberX+  ( CanonicalNumber (..),+    CanonicalFiniteValue,+    mkCanonicalFiniteValue,+    mkCanonicalFiniteNumber,+    canonicalFiniteValue,+    canonicalNumberFromDouble,+    canonicalNumberToMaybeDouble,+  )+import Moonlight.Core.Capability as CapabilityX+import Moonlight.Core.Dedup as DedupX+import Moonlight.Core.DenseKey as DenseKeyX+import Moonlight.Core.DomainId as DomainIdX+import Moonlight.Core.Error as ErrorX+import Moonlight.Core.EGraph.Program as EGraphProgramX+import Moonlight.Core.ExactToken as ExactTokenX+import Moonlight.Core.Finite as FiniteX+import Moonlight.Core.Fix.Order as FixOrderX+import Moonlight.Core.Fixpoint as FixpointX+import Moonlight.Core.Fixpoint.Dense as FixpointDenseX+import Moonlight.Core.Guidance as GuidanceX+import Moonlight.Core.Hash as HashX+import Moonlight.Core.Identifier as IdentifierX+import Moonlight.Core.Identifier.EGraph (PatternVar, mkPatternVar)+import Moonlight.Core.Identifier.EGraph as IdentifierEGraphX hiding (PatternVar, mkPatternVar)+import Moonlight.Core.IsoNorm as IsoNormX+import Moonlight.Core.Language as LanguageX+import Moonlight.Core.LawName as LawNameX+import Moonlight.Core.MapAccum as MapAccumX+import Moonlight.Core.MapInvert as MapInvertX+import Moonlight.Core.Match as MatchX+import Moonlight.Core.ModuleIdentifier as ModuleIdentifierX+import Moonlight.Core.Niche as NicheX+import Moonlight.Core.Numeric as NumericX+  ( OrderedRing,+    OrderedField,+    ContinuousField,+  )+import Moonlight.Core.OrdCollection as OrdCollectionX+import Moonlight.Core.Order as OrderX+import Moonlight.Core.Pattern as PatternX+import Moonlight.Core.ProofManifest as ProofManifestX+import Moonlight.Core.Queue as QueueX+import Moonlight.Core.Refinement as RefinementX+import Moonlight.Core.Relational as RelationalX+import Moonlight.Core.Scan as ScanX+import Moonlight.Core.Scalar as ScalarX+import Moonlight.Core.Site.Program as SiteProgramX+import Moonlight.Core.StableHash as StableHashX+import Moonlight.Core.Substitution as SubstitutionX+import Moonlight.Core.Term.Database as TermDatabaseX+import Moonlight.Core.Term.Database.Canonicalize as TermDatabaseCanonicalizeX+import Moonlight.Core.Theory as TheoryX+import Moonlight.Core.TotalRegistry as TotalRegistryX+import Moonlight.Core.TypeLevel as TypeLevelX+import Moonlight.Core.UnionFind as UnionFindX+import Moonlight.Core.UnionFind.Transaction as UnionFindTransactionX+import Moonlight.Core.Validation as ValidationX
+ src-solver/Moonlight/Core/Fixpoint.hs view
@@ -0,0 +1,73 @@+-- | Bounded fixpoint iteration, worklist scheduling, transitive closure, and a+-- monotone dataflow solver over an abstract delta domain.+--+-- This module is a curated re-export surface. The pure iteration combinators+-- live in "Moonlight.Core.Fixpoint.Internal.Combinators"; the solver's carrier+-- types, plan construction, mutable arena/queue machinery, and evaluation+-- engine live under "Moonlight.Core.Fixpoint.Internal.Solver". 'Evaluation'+-- and 'Plan' are exported abstractly: equation reads are declared by the same+-- applicative program that the arena interprets.+module Moonlight.Core.Fixpoint+  ( FixpointDivergence (..),+    fixpointBounded,+    fixpointBoundedM,+    worklistFold,+    traverseOnceIntSet,+    reschedulingWorklistFoldIntSet,+    EquationId (..),+    Evaluation,+    readEquationValue,+    DeltaDomain (..),+    Equation (..),+    ConvergencePlan (..),+    WideningPolicy (..),+    Plan,+    Obstruction (..),+    Snapshot (..),+    Result (..),+    planFromEquations,+    planWithConvergenceFromEquations,+    solveMonotone,+    solveDenseMonotone,+    solveIncremental,+    closureUnder,+    closureUnderInt,+    reachabilityFrom,+    reachabilityFromInt,+  )+where++import Moonlight.Core.Fixpoint.Internal.Combinators+  ( FixpointDivergence (..),+    closureUnder,+    closureUnderInt,+    fixpointBounded,+    fixpointBoundedM,+    reachabilityFrom,+    reachabilityFromInt,+    reschedulingWorklistFoldIntSet,+    traverseOnceIntSet,+    worklistFold,+  )+import Moonlight.Core.Fixpoint.Internal.Solver.Engine+  ( solveDenseMonotone,+    solveIncremental,+    solveMonotone,+  )+import Moonlight.Core.Fixpoint.Internal.Solver.Plan+  ( planFromEquations,+    planWithConvergenceFromEquations,+  )+import Moonlight.Core.Fixpoint.Internal.Solver.Types+  ( ConvergencePlan (..),+    DeltaDomain (..),+    Equation (..),+    EquationId (..),+    Evaluation,+    Obstruction (..),+    Plan,+    Result (..),+    Snapshot (..),+    WideningPolicy (..),+    readEquationValue,+  )
+ src-solver/Moonlight/Core/Fixpoint/Dense.hs view
@@ -0,0 +1,109 @@+-- | The sole public face of the Dense reachability kernel. The sealed+-- @Dense.Internal.*@ owners are re-exported here as a curated surface:+-- 'Csr', 'FrozenDigraph', and 'SccPlan' stay abstract — their field accessors+-- are exposed as a lawful read-only projection (inspect and force, never forge a+-- malformed CSR or plan), while their constructors remain withheld.+module Moonlight.Core.Fixpoint.Dense+  ( Csr,+    GraphCsr,+    RowCsr,+    csrVertexCount,+    csrOffsets,+    csrTargets,+    csrFromRows,+    csrTargetsForKey,+    csrTargetsSet,+    csrOutDegree,+    csrTranspose,+    SccPlan,+    sccOfVertex,+    sccMembers,+    condensation,+    condensationBackward,+    FrozenDigraph,+    graphForward,+    graphBackward,+    graphSccPlan,+    AdaptiveIntSet,+    ChunkedBitmap,+    BitmapChunk,+    SccClosureCache,+    Edge (..),+    EdgeTombstones,+    GraphSnapshot,+    ReachabilityPolicy,+    ReachabilityPolicyValidationError (..),+    mkReachabilityPolicy,+    defaultReachabilityPolicy,+    sccClosureCacheFor,+    emptyEdgeTombstones,+    frozenDigraphFromSuccessors,+    frozenReachabilityFrom,+    frozenReachabilityWithPolicy,+    frozenReachabilityWithCache,+    snapshotFromFrozen,+    snapshotReachabilityFrom,+    needsCompaction,+    insertSnapshotEdge,+    deleteSnapshotEdge,+    compactSnapshot,+  )+where++import Moonlight.Core.Fixpoint.Dense.Internal.AdaptiveIntSet+  ( AdaptiveIntSet,+    BitmapChunk,+    ChunkedBitmap,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.ClosureCache+  ( SccClosureCache,+    sccClosureCacheFor,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.Csr+  ( Csr,+    GraphCsr,+    RowCsr,+    csrFromRows,+    csrOffsets,+    csrOutDegree,+    csrTargets,+    csrTargetsForKey,+    csrTargetsSet,+    csrTranspose,+    csrVertexCount,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.Policy+  ( ReachabilityPolicy,+    ReachabilityPolicyValidationError (..),+    defaultReachabilityPolicy,+    mkReachabilityPolicy,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.Scc+  ( FrozenDigraph,+    SccPlan,+    condensation,+    condensationBackward,+    frozenDigraphFromSuccessors,+    graphBackward,+    graphForward,+    graphSccPlan,+    sccMembers,+    sccOfVertex,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.Snapshot+  ( Edge (..),+    EdgeTombstones,+    GraphSnapshot,+    compactSnapshot,+    deleteSnapshotEdge,+    emptyEdgeTombstones,+    snapshotFromFrozen,+    needsCompaction,+    insertSnapshotEdge,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.Traverse+  ( frozenReachabilityFrom,+    frozenReachabilityWithCache,+    frozenReachabilityWithPolicy,+    snapshotReachabilityFrom,+  )
+ src-solver/Moonlight/Core/Fixpoint/Dense/Internal/AdaptiveIntSet.hs view
@@ -0,0 +1,209 @@+-- | An adaptive immutable @Int@-set representation — tiny sorted vector,+-- chunked bitmap, or full bitmap — chosen by density, with its codec and the+-- shared @Word64@ bit arithmetic. A pure leaf.+module Moonlight.Core.Fixpoint.Dense.Internal.AdaptiveIntSet+  ( AdaptiveIntSet (..),+    ChunkedBitmap,+    BitmapChunk (..),+    adaptiveIntSetFromIntSet,+    adaptiveIntSetToIntSet,+    wordBits,+    wordCountForSize,+  )+where++import Data.Bits (shiftL, testBit, (.|.))+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Kind (Type)+import Data.List qualified as List+import Data.Vector.Unboxed (Vector)+import Data.Vector.Unboxed qualified as U+import Data.Word (Word64)+import Prelude++type AdaptiveIntSet :: Type+data AdaptiveIntSet+  = TinySorted !(Vector Int)+  | ChunkedBitmap !ChunkedBitmap+  | FullBitmap !(Vector Word64)+  deriving stock (Eq, Show)++type ChunkedBitmap :: Type+data ChunkedBitmap = ChunkedBitmapData+  { chunkedBitmapChunkBits :: !Int,+    chunkedBitmapChunks :: !(IntMap.IntMap BitmapChunk)+  }+  deriving stock (Eq, Show)++type BitmapChunk :: Type+data BitmapChunk+  = SortedChunk !(Vector Int)+  | BitmapChunkWords !(Vector Word64)+  deriving stock (Eq, Show)++adaptiveIntSetTinyLimit :: Int+adaptiveIntSetTinyLimit =+  64+{-# INLINE adaptiveIntSetTinyLimit #-}++adaptiveIntSetChunkBits :: Int+adaptiveIntSetChunkBits =+  12+{-# INLINE adaptiveIntSetChunkBits #-}++adaptiveIntSetChunkSize :: Int+adaptiveIntSetChunkSize =+  chunkSizeForBits adaptiveIntSetChunkBits+{-# INLINE adaptiveIntSetChunkSize #-}++chunkSizeForBits :: Int -> Int+chunkSizeForBits chunkBits =+  1 `shiftL` max 0 chunkBits+{-# INLINE chunkSizeForBits #-}++adaptiveIntSetChunkBitmapLimit :: Int+adaptiveIntSetChunkBitmapLimit =+  wordCountForSize adaptiveIntSetChunkSize+{-# INLINE adaptiveIntSetChunkBitmapLimit #-}++adaptiveIntSetFullBitmapDensity :: Int+adaptiveIntSetFullBitmapDensity =+  8+{-# INLINE adaptiveIntSetFullBitmapDensity #-}++adaptiveIntSetFromIntSet :: IntSet -> AdaptiveIntSet+adaptiveIntSetFromIntSet values+  | IntSet.size values <= adaptiveIntSetTinyLimit =+      TinySorted (U.fromList (IntSet.toAscList values))+  | fullBitmapPreferred values =+      FullBitmap (bitmapFromIntSet values)+  | otherwise =+      ChunkedBitmap (chunkedBitmapFromIntSet values)+{-# INLINE adaptiveIntSetFromIntSet #-}++adaptiveIntSetToIntSet :: AdaptiveIntSet -> IntSet+adaptiveIntSetToIntSet adaptive =+  case adaptive of+    TinySorted values ->+      IntSet.fromDistinctAscList (U.toList values)+    ChunkedBitmap chunks ->+      chunkedBitmapToIntSet chunks+    FullBitmap bitmapWords ->+      bitmapToIntSet bitmapWords+{-# INLINE adaptiveIntSetToIntSet #-}++fullBitmapPreferred :: IntSet -> Bool+fullBitmapPreferred values =+  case (IntSet.lookupMin values, IntSet.lookupMax values) of+    (Just minimumKey, Just maximumKey)+      | minimumKey >= 0 ->+          IntSet.size values * adaptiveIntSetFullBitmapDensity >= maximumKey + 1+    _ ->+      False+{-# INLINE fullBitmapPreferred #-}++chunkedBitmapFromIntSet :: IntSet -> ChunkedBitmap+chunkedBitmapFromIntSet values =+  ChunkedBitmapData+    { chunkedBitmapChunkBits = adaptiveIntSetChunkBits,+      chunkedBitmapChunks =+        fmap bitmapChunkFromOffsets $+          IntMap.fromListWith+            (<>)+            [ (chunkIndex, [chunkOffset])+              | key <- IntSet.toAscList values,+                let (chunkIndex, chunkOffset) = key `divMod` adaptiveIntSetChunkSize+            ]+    }+{-# INLINE chunkedBitmapFromIntSet #-}++bitmapChunkFromOffsets :: [Int] -> BitmapChunk+bitmapChunkFromOffsets offsets+  | length sortedOffsets <= adaptiveIntSetChunkBitmapLimit =+      SortedChunk (U.fromList sortedOffsets)+  | otherwise =+      BitmapChunkWords (bitmapFromOffsets sortedOffsets)+  where+    sortedOffsets =+      List.sort offsets+{-# INLINE bitmapChunkFromOffsets #-}++bitmapFromOffsets :: [Int] -> Vector Word64+bitmapFromOffsets offsets =+  U.generate+    (wordCountForSize adaptiveIntSetChunkSize)+    (\wordIndex -> IntMap.findWithDefault 0 wordIndex wordsByIndex)+  where+    wordsByIndex =+      foldl' insertOffset IntMap.empty offsets+    insertOffset bitmapWords offset =+      IntMap.insertWith (.|.) (offset `quot` wordBits) (bitMask (offset `rem` wordBits)) bitmapWords+{-# INLINE bitmapFromOffsets #-}++chunkedBitmapToIntSet :: ChunkedBitmap -> IntSet+chunkedBitmapToIntSet (ChunkedBitmapData chunkBits chunks) =+  IntSet.fromDistinctAscList $+    concatMap chunkEntries (IntMap.toAscList chunks)+  where+    chunkSize =+      chunkSizeForBits chunkBits+    chunkEntries (chunkIndex, chunk) =+      fmap (+ (chunkIndex * chunkSize)) (bitmapChunkOffsets chunk)+{-# INLINE chunkedBitmapToIntSet #-}++bitmapChunkOffsets :: BitmapChunk -> [Int]+bitmapChunkOffsets chunk =+  case chunk of+    SortedChunk offsets ->+      U.toList offsets+    BitmapChunkWords bitmapWords ->+      bitmapOffsets bitmapWords+{-# INLINE bitmapChunkOffsets #-}++bitmapOffsets :: Vector Word64 -> [Int]+bitmapOffsets bitmapWords =+  [ wordIndex * wordBits + bitIndex+    | (wordIndex, word) <- zip [0 ..] (U.toList bitmapWords),+      bitIndex <- [0 .. wordBits - 1],+      testBit word bitIndex+  ]+{-# INLINE bitmapOffsets #-}++bitmapFromIntSet :: IntSet -> Vector Word64+bitmapFromIntSet values =+  U.generate wordCount (\wordIndex -> IntMap.findWithDefault 0 wordIndex wordsByIndex)+  where+    wordCount =+      maybe 0 ((+ 1) . (`quot` wordBits)) (IntSet.lookupMax values)+    wordsByIndex =+      IntSet.foldl' insertBit IntMap.empty values+    insertBit bitmapWords key =+      IntMap.insertWith (.|.) (key `quot` wordBits) (bitMask (key `rem` wordBits)) bitmapWords+{-# INLINE bitmapFromIntSet #-}++bitmapToIntSet :: Vector Word64 -> IntSet+bitmapToIntSet bitmapWords =+  IntSet.fromDistinctAscList+    [ wordIndex * wordBits + bitIndex+      | (wordIndex, word) <- zip [0 ..] (U.toList bitmapWords),+        bitIndex <- [0 .. wordBits - 1],+        testBit word bitIndex+    ]+{-# INLINE bitmapToIntSet #-}++wordBits :: Int+wordBits =+  64+{-# INLINE wordBits #-}++wordCountForSize :: Int -> Int+wordCountForSize size =+  (max 0 size + wordBits - 1) `quot` wordBits+{-# INLINE wordCountForSize #-}++bitMask :: Int -> Word64+bitMask bitIndex =+  (1 :: Word64) `shiftL` bitIndex+{-# INLINE bitMask #-}
+ src-solver/Moonlight/Core/Fixpoint/Dense/Internal/ClosureCache.hs view
@@ -0,0 +1,143 @@+-- | A graph-bound memoized transitive-closure cache over the SCC condensation:+-- reachable-component closures are computed by depth-first descent, memoized per+-- descent, and materialized into the persistent cache once a component has been+-- queried often enough to earn its keep.+module Moonlight.Core.Fixpoint.Dense.Internal.ClosureCache+  ( SccClosureCache,+    sccClosureCacheFor,+    closureCacheGraph,+    closeComponents,+  )+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.Kind (Type)+import Moonlight.Core.Fixpoint.Dense.Internal.AdaptiveIntSet+  ( AdaptiveIntSet,+    adaptiveIntSetFromIntSet,+    adaptiveIntSetToIntSet,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.Csr (csrTargetsSet)+import Moonlight.Core.Fixpoint.Dense.Internal.Scc+  ( FrozenDigraph (..),+    SccPlan (..),+  )+import Prelude++type SccClosureCache :: Type+data SccClosureCache = SccClosureCache+  { closureCacheGraph :: !FrozenDigraph,+    cachedClosures :: !(IntMap AdaptiveIntSet),+    queryCounts :: !(IntMap Int),+    materializeAfter :: !Int+  }+  deriving stock (Eq, Show)++type ClosureDescent :: Type+data ClosureDescent = ClosureDescent+  { cacheState :: !SccClosureCache,+    memo :: !(IntMap IntSet)+  }++sccClosureCacheFor :: FrozenDigraph -> SccClosureCache+sccClosureCacheFor graph =+  SccClosureCache+    { closureCacheGraph = graph,+      cachedClosures = IntMap.empty,+      queryCounts = IntMap.empty,+      materializeAfter = 2+    }++closeComponents :: IntSet -> SccClosureCache -> (IntSet, SccClosureCache)+closeComponents components cache =+  let (closed, descent) =+        IntSet.foldl'+          closeComponentInto+          ( IntSet.empty,+            ClosureDescent+              { cacheState = cache,+                memo = IntMap.empty+              }+          )+          components+   in (closed, cacheState descent)+  where+    plan =+      graphSccPlan (closureCacheGraph cache)+    closeComponentInto (closed, currentDescent) component =+      let (closedComponent, nextDescent) = cachedComponentClosure plan component currentDescent+       in (IntSet.union closed closedComponent, nextDescent)++cachedComponentClosure :: SccPlan -> Int -> ClosureDescent -> (IntSet, ClosureDescent)+cachedComponentClosure plan component descent =+  case lookupComponentClosure component descent of+    Just closure ->+      (closure, descent)+    Nothing ->+      let queriedDescent =+            descent+              { cacheState =+                  queryComponentClosure component (cacheState descent)+              }+          (closure, closedDescent) =+            componentClosure plan component queriedDescent+       in (closure, rememberComponentClosure component closure closedDescent)++componentClosure :: SccPlan -> Int -> ClosureDescent -> (IntSet, ClosureDescent)+componentClosure plan component descent =+  IntSet.foldl'+    closeSuccessor+    (IntSet.singleton component, descent)+    (csrTargetsSet (condensation plan) component)+  where+    closeSuccessor (closed, currentDescent) successor =+      let (successorClosure, nextDescent) =+            cachedComponentClosure plan successor currentDescent+       in (IntSet.union closed successorClosure, nextDescent)+{-# INLINE componentClosure #-}++lookupComponentClosure :: Int -> ClosureDescent -> Maybe IntSet+lookupComponentClosure component descent =+  case IntMap.lookup component (cachedClosures (cacheState descent)) of+    Just closure ->+      Just (adaptiveIntSetToIntSet closure)+    Nothing ->+      IntMap.lookup component (memo descent)+{-# INLINE lookupComponentClosure #-}++queryComponentClosure :: Int -> SccClosureCache -> SccClosureCache+queryComponentClosure component cache =+  cache+    { queryCounts =+        IntMap.insertWith (+) component 1 (queryCounts cache)+    }+{-# INLINE queryComponentClosure #-}++rememberComponentClosure :: Int -> IntSet -> ClosureDescent -> ClosureDescent+rememberComponentClosure component closure descent =+  descent+    { cacheState =+        cacheComponentClosure component closure (cacheState descent),+      memo =+        IntMap.insert component closure (memo descent)+    }+{-# INLINE rememberComponentClosure #-}++cacheComponentClosure :: Int -> IntSet -> SccClosureCache -> SccClosureCache+cacheComponentClosure component closure cache+  | queryCount >= max 1 (materializeAfter cache) =+      cache+        { cachedClosures =+            IntMap.insert component (adaptiveIntSetFromIntSet closure) (cachedClosures cache),+          queryCounts =+            IntMap.delete component (queryCounts cache)+        }+  | otherwise =+      cache+  where+    queryCount =+      IntMap.findWithDefault 0 component (queryCounts cache)+{-# INLINE cacheComponentClosure #-}
+ src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Csr.hs view
@@ -0,0 +1,124 @@+-- | Compressed-sparse-row adjacency for finite @Int@ digraphs: construction+-- from rows, per-vertex target slices, out-degree, and transpose. A pure leaf.+module Moonlight.Core.Fixpoint.Dense.Internal.Csr+  ( CsrRole (..),+    Csr (..),+    GraphCsr,+    RowCsr,+    csrFromRows,+    csrFromBoundedRows,+    csrTargetsForKey,+    csrTargetsSet,+    csrOutDegree,+    csrTranspose,+    inBounds,+  )+where++import Control.Monad.ST (runST)+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Kind (Type)+import Data.List qualified as List+import Data.Vector.Unboxed (Vector)+import Data.Vector.Unboxed qualified as U+import Data.Vector.Unboxed.Mutable qualified as UM+import Prelude++data CsrRole+  = SquareGraph+  | RectangularRows++type Csr :: CsrRole -> Type+data Csr shape = Csr+  { csrVertexCount :: !Int,+    csrOffsets :: !(Vector Int),+    csrTargets :: !(Vector Int)+  }+  deriving stock (Eq, Show)++type GraphCsr = Csr 'SquareGraph++type RowCsr = Csr 'RectangularRows++csrFromRows :: Int -> [[Int]] -> RowCsr+csrFromRows vertexCount rows =+  csrFromRowsWith (const True) vertexCount rows+{-# INLINE csrFromRows #-}++csrFromBoundedRows :: Int -> [[Int]] -> GraphCsr+csrFromBoundedRows vertexCount rows =+  csrFromRowsWith (inBounds n) n rows+  where+    n = max 0 vertexCount+{-# INLINE csrFromBoundedRows #-}++csrFromRowsWith :: (Int -> Bool) -> Int -> [[Int]] -> Csr shape+csrFromRowsWith keepTarget vertexCount rows =+  Csr+    { csrVertexCount = n,+      csrOffsets = U.fromList offsets,+      csrTargets = U.fromList targets+    }+  where+    n = max 0 vertexCount+    normalizedRows =+      fmap+        (IntSet.toAscList . IntSet.filter keepTarget . IntSet.fromList)+        (take n (rows <> repeat []))+    offsets = List.scanl' (+) 0 (fmap length normalizedRows)+    targets = concat normalizedRows+{-# INLINE csrFromRowsWith #-}++csrTranspose :: GraphCsr -> GraphCsr+csrTranspose csr =+  runST $ do+    incomingCounts <- UM.replicate vertexCount 0+    U.mapM_ (UM.modify incomingCounts (+ 1)) inputTargets+    frozenIncomingCounts <- U.unsafeFreeze incomingCounts+    let transposedOffsets = U.scanl' (+) 0 frozenIncomingCounts+    insertionOffsets <- U.thaw (U.init transposedOffsets)+    transposedTargets <- UM.new (U.length inputTargets)+    U.mapM_+      ( \source ->+          U.mapM_+            ( \target -> do+                insertionOffset <- UM.read insertionOffsets target+                UM.write transposedTargets insertionOffset source+                UM.write insertionOffsets target (insertionOffset + 1)+            )+            (csrTargetsForKey csr source)+      )+      (U.enumFromN 0 vertexCount)+    frozenTransposedTargets <- U.unsafeFreeze transposedTargets+    pure+      Csr+        { csrVertexCount = vertexCount,+          csrOffsets = transposedOffsets,+          csrTargets = frozenTransposedTargets+        }+  where+    vertexCount = csrVertexCount csr+    inputTargets = csrTargets csr+{-# INLINE csrTranspose #-}++csrTargetsForKey :: Csr shape -> Int -> Vector Int+csrTargetsForKey csr key =+  case (csrOffsets csr U.!? key, csrOffsets csr U.!? (key + 1)) of+    (Just offset, Just nextOffset) -> U.slice offset (nextOffset - offset) (csrTargets csr)+    _ -> U.empty+{-# INLINE csrTargetsForKey #-}++csrTargetsSet :: Csr shape -> Int -> IntSet+csrTargetsSet csr key =+  IntSet.fromDistinctAscList (U.toList (csrTargetsForKey csr key))+{-# INLINE csrTargetsSet #-}++csrOutDegree :: Csr shape -> Int -> Int+csrOutDegree csr key =+  U.length (csrTargetsForKey csr key)+{-# INLINE csrOutDegree #-}++inBounds :: Int -> Int -> Bool+inBounds n key = key >= 0 && key < n+{-# INLINE inBounds #-}
+ src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Policy.hs view
@@ -0,0 +1,54 @@+-- | The adaptive push/pull reachability policy: validated ratio thresholds and+-- the small-frontier cutoff that decide when to switch traversal direction.+module Moonlight.Core.Fixpoint.Dense.Internal.Policy+  ( ReachabilityPolicy (..),+    ReachabilityPolicyValidationError (..),+    mkReachabilityPolicy,+    defaultReachabilityPolicy,+  )+where++import Prelude++data ReachabilityPolicy = ReachabilityPolicy+  { pushToPullRatio :: !Double,+    pullToPushRatio :: !Double,+    smallFrontierLimit :: !Int+  }+  deriving stock (Eq, Show)++data ReachabilityPolicyValidationError+  = PushToPullRatioIsNaN+  | PullToPushRatioIsNaN+  | NegativePushToPullRatio !Double+  | NegativePullToPushRatio !Double+  | NegativeSmallFrontierLimit !Int+  deriving stock (Eq, Show)++mkReachabilityPolicy :: Double -> Double -> Int -> Either ReachabilityPolicyValidationError ReachabilityPolicy+mkReachabilityPolicy pushRatio pullRatio frontierLimit+  | isNaN pushRatio =+      Left PushToPullRatioIsNaN+  | isNaN pullRatio =+      Left PullToPushRatioIsNaN+  | pushRatio < 0 =+      Left (NegativePushToPullRatio pushRatio)+  | pullRatio < 0 =+      Left (NegativePullToPushRatio pullRatio)+  | frontierLimit < 0 =+      Left (NegativeSmallFrontierLimit frontierLimit)+  | otherwise =+      Right+        ReachabilityPolicy+          { pushToPullRatio = pushRatio,+            pullToPushRatio = pullRatio,+            smallFrontierLimit = frontierLimit+          }++defaultReachabilityPolicy :: ReachabilityPolicy+defaultReachabilityPolicy =+  ReachabilityPolicy+    { pushToPullRatio = 0.05,+      pullToPushRatio = 0.20,+      smallFrontierLimit = 64+    }
+ src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Scc.hs view
@@ -0,0 +1,101 @@+-- | Strongly-connected-component condensation over CSR digraphs: the SCC plan+-- (vertex→component map, members, forward/backward condensation), frozen+-- digraph construction, and component expansion back to vertices.+module Moonlight.Core.Fixpoint.Dense.Internal.Scc+  ( SccPlan (..),+    FrozenDigraph (..),+    frozenDigraphFromSuccessors,+    expandComponents,+  )+where++import Data.Graph qualified as Graph+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Kind (Type)+import Data.List qualified as List+import Data.Vector.Unboxed (Vector)+import Data.Vector.Unboxed qualified as U+import Moonlight.Core.Fixpoint.Dense.Internal.Csr+  ( GraphCsr,+    RowCsr,+    csrFromBoundedRows,+    csrFromRows,+    csrTargetsForKey,+    csrTargetsSet,+    csrTranspose,+    csrVertexCount,+  )+import Prelude++type SccPlan :: Type+data SccPlan = SccPlan+  { sccOfVertex :: !(Vector Int),+    sccMembers :: !RowCsr,+    condensation :: !GraphCsr,+    condensationBackward :: !GraphCsr+  }+  deriving stock (Eq, Show)++type FrozenDigraph :: Type+data FrozenDigraph = FrozenDigraph+  { graphForward :: !GraphCsr,+    graphBackward :: !GraphCsr,+    graphSccPlan :: !SccPlan+  }+  deriving stock (Eq, Show)++frozenDigraphFromSuccessors :: Int -> (Int -> IntSet) -> FrozenDigraph+frozenDigraphFromSuccessors size successors =+  FrozenDigraph+    { graphForward = forward,+      graphBackward = backward,+      graphSccPlan = sccPlanFromCsr forward+    }+  where+    n = max 0 size+    forward = csrFromBoundedRows n [IntSet.toAscList (successors v) | v <- [0 .. n - 1]]+    backward = csrTranspose forward+{-# INLINE frozenDigraphFromSuccessors #-}++sccPlanFromCsr :: GraphCsr -> SccPlan+sccPlanFromCsr forward =+  SccPlan+    { sccOfVertex = vertexComponents,+      sccMembers = csrFromRows componentCount (fmap List.sort components),+      condensation = condensationForward,+      condensationBackward = csrTranspose condensationForward+    }+  where+    components =+      fmap sccVertices $+        Graph.stronglyConnComp+          [(v, v, U.toList (csrTargetsForKey forward v)) | v <- [0 .. csrVertexCount forward - 1]]+    componentCount = length components+    componentEntries = zip [0 ..] components+    vertexComponentMap =+      IntMap.fromList [(v, componentId) | (componentId, vs) <- componentEntries, v <- vs]+    vertexComponents =+      U.generate (csrVertexCount forward) (\v -> IntMap.findWithDefault v v vertexComponentMap)+    condensationForward =+      csrFromBoundedRows componentCount [IntSet.toAscList (successors componentId vs) | (componentId, vs) <- componentEntries]+    successors componentId vs =+      IntSet.delete componentId $+        IntSet.fromList+          [ targetComponent+            | v <- vs,+              target <- U.toList (csrTargetsForKey forward v),+              Just targetComponent <- [vertexComponents U.!? target]+          ]+    sccVertices :: Graph.SCC Int -> [Int]+    sccVertices scc =+      case scc of+        Graph.AcyclicSCC v -> [v]+        Graph.CyclicSCC vs -> List.sort vs+{-# INLINE sccPlanFromCsr #-}++expandComponents :: SccPlan -> IntSet -> IntSet+expandComponents plan =+  IntSet.foldl' (\acc component -> IntSet.union acc (csrTargetsSet (sccMembers plan) component)) IntSet.empty+{-# INLINE expandComponents #-}
+ src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Scratch.hs view
@@ -0,0 +1,312 @@+-- | The graph-agnostic mutable workspace for adaptive reachability: the+-- double-buffered sparse/dense frontier scratch arena, generation-stamped visit+-- marks, frontier folds/membership, and the strict monadic fold primitive. This+-- is the rawest ST stratum — it names neither 'Csr' nor 'GraphSnapshot'.+module Moonlight.Core.Fixpoint.Dense.Internal.Scratch+  ( ScratchSide (..),+    Frontier (..),+    ReachabilityScratch,+    newReachabilityScratch,+    nextReachabilityGeneration,+    markVectorFresh,+    appendFreshTarget,+    appendSparseBuffer,+    writeDenseFrontierM,+    flipScratchSide,+    markVisited,+    isMarked,+    visitedMarksToIntSet,+    strictFoldM,+    frontierEmpty,+    frontierSize,+    frontierMemberM,+    frontierContainsAnyM,+    frontierFoldM',+  )+where++import Control.Monad.ST (ST)+import Data.Bits (setBit, testBit)+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Kind (Type)+import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)+import Data.Vector.Unboxed (Vector)+import Data.Vector.Unboxed qualified as U+import Data.Vector.Unboxed.Mutable qualified as UM+import Data.Word (Word32, Word64)+import Moonlight.Core.Fixpoint.Dense.Internal.AdaptiveIntSet (wordBits, wordCountForSize)+import Prelude++data ScratchSide+  = ScratchA+  | ScratchB+  deriving stock (Eq, Show)++data Frontier+  = SparseFrontier !ScratchSide !Int+  | DenseFrontier !ScratchSide !Int+  deriving stock (Eq, Show)++type ReachabilityScratch :: Type -> Type+data ReachabilityScratch state = ReachabilityScratch+  { visitedGeneration :: !(UM.MVector state Word32),+    currentGeneration :: !(STRef state Word32),+    sparseA :: !(UM.MVector state Int),+    sparseB :: !(UM.MVector state Int),+    denseA :: !(UM.MVector state Word64),+    denseB :: !(UM.MVector state Word64)+  }++newReachabilityScratch :: Int -> ST state (ReachabilityScratch state)+newReachabilityScratch vertexCount = do+  visited <- UM.replicate (max 0 vertexCount) 0+  firstSparse <- UM.replicate (max 0 vertexCount) 0+  secondSparse <- UM.replicate (max 0 vertexCount) 0+  firstDense <- UM.replicate (wordCountForSize vertexCount) 0+  secondDense <- UM.replicate (wordCountForSize vertexCount) 0+  generation <- newSTRef 0+  pure+    ReachabilityScratch+      { visitedGeneration = visited,+        currentGeneration = generation,+        sparseA = firstSparse,+        sparseB = secondSparse,+        denseA = firstDense,+        denseB = secondDense+      }+{-# INLINE newReachabilityScratch #-}++nextReachabilityGeneration :: ReachabilityScratch state -> ST state Word32+nextReachabilityGeneration scratch = do+  previous <- readSTRef (currentGeneration scratch)+  let next = previous + 1+  if next == 0+    then do+      UM.set (visitedGeneration scratch) 0+      writeSTRef (currentGeneration scratch) 1+      pure 1+    else do+      writeSTRef (currentGeneration scratch) next+      pure next+{-# INLINE nextReachabilityGeneration #-}++frontierEmpty :: Frontier -> Bool+frontierEmpty frontier =+  case frontier of+    SparseFrontier _ frontierLength -> frontierLength <= 0+    DenseFrontier _ frontierLength -> frontierLength <= 0+{-# INLINE frontierEmpty #-}++frontierSize :: Frontier -> Int+frontierSize frontier =+  case frontier of+    SparseFrontier _ frontierLength -> frontierLength+    DenseFrontier _ frontierLength -> frontierLength+{-# INLINE frontierSize #-}++frontierMemberM :: ReachabilityScratch state -> Frontier -> Int -> ST state Bool+frontierMemberM scratch frontier key =+  case frontier of+    SparseFrontier side frontierLength ->+      sparseFrontierMemberM (sparseBufferFor side scratch) frontierLength key+    DenseFrontier side _ ->+      denseFrontierMemberM (denseBufferFor side scratch) key+{-# INLINE frontierMemberM #-}++frontierContainsAnyM :: ReachabilityScratch state -> Frontier -> Vector Int -> ST state Bool+frontierContainsAnyM scratch frontier =+  U.foldr+    ( \key remaining -> do+        found <- frontierMemberM scratch frontier key+        if found then pure True else remaining+    )+    (pure False)+{-# INLINE frontierContainsAnyM #-}++frontierFoldM' :: ReachabilityScratch state -> (result -> Int -> ST state result) -> result -> Frontier -> ST state result+frontierFoldM' scratch step initial frontier =+  case frontier of+    SparseFrontier side frontierLength ->+      sparseFrontierFoldM' (sparseBufferFor side scratch) frontierLength step initial+    DenseFrontier side _ ->+      denseFrontierFoldM' (denseBufferFor side scratch) step initial+{-# INLINE frontierFoldM' #-}++markVectorFresh :: ReachabilityScratch state -> Word32 -> ScratchSide -> Vector Int -> ST state Int+markVectorFresh scratch generation targetSide =+  U.foldM' mark 0+  where+    mark freshLength key = do+      marked <- markFresh scratch generation key+      if marked+        then appendSparseBuffer scratch targetSide freshLength key+        else pure freshLength+{-# INLINE markVectorFresh #-}++appendFreshTarget :: ReachabilityScratch state -> Word32 -> ScratchSide -> Int -> Int -> ST state Int+appendFreshTarget scratch generation targetSide freshLength target = do+  marked <- markFresh scratch generation target+  if marked+    then appendSparseBuffer scratch targetSide freshLength target+    else pure freshLength+{-# INLINE appendFreshTarget #-}++appendSparseBuffer :: ReachabilityScratch state -> ScratchSide -> Int -> Int -> ST state Int+appendSparseBuffer scratch targetSide index value+  | index >= UM.length target = pure index+  | otherwise = do+      UM.write target index value+      pure (index + 1)+  where+    target =+      sparseBufferFor targetSide scratch+{-# INLINE appendSparseBuffer #-}++writeDenseFrontierM :: ReachabilityScratch state -> ScratchSide -> ScratchSide -> Int -> ST state ()+writeDenseFrontierM scratch sourceSide targetSide frontierLength = do+  UM.set target 0+  strictFoldM+    ( \() index -> do+        value <- UM.read source index+        setDenseBit target value+    )+    ()+    [0 .. frontierLength - 1]+  where+    source =+      sparseBufferFor sourceSide scratch+    target =+      denseBufferFor targetSide scratch+{-# INLINE writeDenseFrontierM #-}++sparseFrontierFoldM' :: UM.MVector state Int -> Int -> (result -> Int -> ST state result) -> result -> ST state result+sparseFrontierFoldM' sparse frontierLength step initial =+  strictFoldM+    ( \acc index -> do+        value <- UM.read sparse index+        step acc value+    )+    initial+    [0 .. frontierLength - 1]+{-# INLINE sparseFrontierFoldM' #-}++denseFrontierFoldM' :: UM.MVector state Word64 -> (result -> Int -> ST state result) -> result -> ST state result+denseFrontierFoldM' dense step initial =+  strictFoldM foldWord initial [0 .. UM.length dense - 1]+  where+    foldWord acc wordIndex = do+      word <- UM.read dense wordIndex+      strictFoldM+        ( \current bitIndex ->+            if testBit word bitIndex+              then step current (wordIndex * wordBits + bitIndex)+              else pure current+        )+        acc+        [0 .. wordBits - 1]+{-# INLINE denseFrontierFoldM' #-}++sparseFrontierMemberM :: UM.MVector state Int -> Int -> Int -> ST state Bool+sparseFrontierMemberM sparse frontierLength key =+  foldr+    ( \index remaining -> do+        found <- (== key) <$> UM.read sparse index+        if found then pure True else remaining+    )+    (pure False)+    [0 .. frontierLength - 1]+{-# INLINE sparseFrontierMemberM #-}++denseFrontierMemberM :: UM.MVector state Word64 -> Int -> ST state Bool+denseFrontierMemberM dense key+  | key < 0 = pure False+  | wordIndex >= UM.length dense = pure False+  | otherwise = do+      word <- UM.read dense wordIndex+      pure (testBit word bitIndex)+  where+    wordIndex =+      key `quot` wordBits+    bitIndex =+      key `rem` wordBits+{-# INLINE denseFrontierMemberM #-}++sparseBufferFor :: ScratchSide -> ReachabilityScratch state -> UM.MVector state Int+sparseBufferFor side scratch =+  case side of+    ScratchA -> sparseA scratch+    ScratchB -> sparseB scratch+{-# INLINE sparseBufferFor #-}++denseBufferFor :: ScratchSide -> ReachabilityScratch state -> UM.MVector state Word64+denseBufferFor side scratch =+  case side of+    ScratchA -> denseA scratch+    ScratchB -> denseB scratch+{-# INLINE denseBufferFor #-}++flipScratchSide :: ScratchSide -> ScratchSide+flipScratchSide side =+  case side of+    ScratchA -> ScratchB+    ScratchB -> ScratchA+{-# INLINE flipScratchSide #-}++markFresh :: ReachabilityScratch state -> Word32 -> Int -> ST state Bool+markFresh scratch generation key+  | key < 0 = pure False+  | key >= UM.length (visitedGeneration scratch) = pure False+  | otherwise = do+      seen <- isMarked scratch generation key+      if seen+        then pure False+        else markVisited scratch generation key *> pure True+{-# INLINE markFresh #-}++markVisited :: ReachabilityScratch state -> Word32 -> Int -> ST state ()+markVisited scratch generation key =+  UM.write (visitedGeneration scratch) key generation+{-# INLINE markVisited #-}++isMarked :: ReachabilityScratch state -> Word32 -> Int -> ST state Bool+isMarked scratch generation key =+  (== generation) <$> UM.read (visitedGeneration scratch) key+{-# INLINE isMarked #-}++visitedMarksToIntSet :: ReachabilityScratch state -> Word32 -> ST state IntSet+visitedMarksToIntSet scratch generation =+  IntSet.fromDistinctAscList . reverse+    <$> strictFoldM step [] [0 .. UM.length (visitedGeneration scratch) - 1]+  where+    step keys key = do+      seen <- isMarked scratch generation key+      pure (if seen then key : keys else keys)+{-# INLINE visitedMarksToIntSet #-}++setDenseBit :: UM.MVector state Word64 -> Int -> ST state ()+setDenseBit bitmap key+  | key < 0 = pure ()+  | wordIndex >= UM.length bitmap = pure ()+  | otherwise = do+      word <- UM.read bitmap wordIndex+      UM.write bitmap wordIndex (setBit word bitIndex)+  where+    wordIndex =+      key `quot` wordBits+    bitIndex =+      key `rem` wordBits+{-# INLINE setDenseBit #-}++strictFoldM :: (Monad m) => (accumulator -> item -> m accumulator) -> accumulator -> [item] -> m accumulator+strictFoldM step initial items =+  initial `seq` go initial items+  where+    go accumulator remaining =+      case remaining of+        [] ->+          pure accumulator+        item : rest -> do+          next <- step accumulator item+          next `seq` go next rest+{-# INLINE strictFoldM #-}
+ src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Snapshot.hs view
@@ -0,0 +1,235 @@+-- | A mutable-graph overlay over a frozen digraph: inserted-edge overlay,+-- deleted-edge tombstones, epoch-driven compaction, and the pure live-edge and+-- successor projections the traversal engine consumes. Entirely pure — no ST.+module Moonlight.Core.Fixpoint.Dense.Internal.Snapshot+  ( Edge (..),+    EdgeTombstones (..),+    GraphSnapshot (..),+    emptyEdgeTombstones,+    snapshotFromFrozen,+    insertSnapshotEdge,+    deleteSnapshotEdge,+    compactSnapshot,+    needsCompaction,+    edgeLive,+  )+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.Kind (Type)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Vector.Unboxed qualified as U+import Moonlight.Core.Fixpoint.Dense.Internal.Csr+  ( csrTargets,+    csrTargetsForKey,+    csrTargetsSet,+    csrVertexCount,+    inBounds,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.Scc+  ( FrozenDigraph (..),+    frozenDigraphFromSuccessors,+  )+import Prelude++type Edge :: Type+data Edge = Edge+  { edgeSource :: !Int,+    edgeTarget :: !Int+  }+  deriving stock (Eq, Ord, Show)++type EdgeTombstones :: Type+newtype EdgeTombstones = EdgeTombstones+  { unEdgeTombstones :: Set Edge+  }+  deriving stock (Eq, Show)++type GraphSnapshot :: Type+data GraphSnapshot = GraphSnapshot+  { frozenBase :: !FrozenDigraph,+    insertedEdgeOverlay :: !(IntMap IntSet),+    deletedEdges :: !EdgeTombstones,+    epoch :: !Int+  }+  deriving stock (Eq, Show)++emptyEdgeTombstones :: EdgeTombstones+emptyEdgeTombstones =+  EdgeTombstones Set.empty++snapshotFromFrozen :: FrozenDigraph -> GraphSnapshot+snapshotFromFrozen graph =+  GraphSnapshot+    { frozenBase = graph,+      insertedEdgeOverlay = IntMap.empty,+      deletedEdges = emptyEdgeTombstones,+      epoch = 0+    }++insertSnapshotEdge :: Edge -> GraphSnapshot -> GraphSnapshot+insertSnapshotEdge edge snapshot =+  if not (edgeInBounds snapshot edge) || snapshotContainsEdge snapshot edge+    then snapshot+    else+      applyEdgeEdit+        ( if baseContainsEdge snapshot edge+            then insertedEdgeOverlay snapshot+            else+              IntMap.insertWith+                IntSet.union+                (edgeSource edge)+                (IntSet.singleton (edgeTarget edge))+                (insertedEdgeOverlay snapshot)+        )+        (deleteTombstone edge (deletedEdges snapshot))+        snapshot++deleteSnapshotEdge :: Edge -> GraphSnapshot -> GraphSnapshot+deleteSnapshotEdge edge snapshot =+  if not (snapshotContainsEdge snapshot edge)+    then snapshot+    else+      applyEdgeEdit+        ( IntMap.update+            (keepNonEmptyIntSet . IntSet.delete (edgeTarget edge))+            (edgeSource edge)+            (insertedEdgeOverlay snapshot)+        )+        ( if baseContainsEdge snapshot edge+            then insertTombstone edge (deletedEdges snapshot)+            else deletedEdges snapshot+        )+        snapshot++applyEdgeEdit :: IntMap IntSet -> EdgeTombstones -> GraphSnapshot -> GraphSnapshot+applyEdgeEdit nextOverlay nextTombstones snapshot =+  compactIfNeeded+    snapshot+      { insertedEdgeOverlay = nextOverlay,+        deletedEdges = nextTombstones,+        epoch = epoch snapshot + 1+      }++edgeInBounds :: GraphSnapshot -> Edge -> Bool+edgeInBounds snapshot edge =+  inBounds vertexCount (edgeSource edge)+    && inBounds vertexCount (edgeTarget edge)+  where+    vertexCount =+      csrVertexCount (graphForward (frozenBase snapshot))++snapshotContainsEdge :: GraphSnapshot -> Edge -> Bool+snapshotContainsEdge snapshot edge =+  edgeInBounds snapshot edge+    && not (edgeTombstoned snapshot edge)+    && (baseContainsEdge snapshot edge || overlayContainsEdge snapshot edge)++baseContainsEdge :: GraphSnapshot -> Edge -> Bool+baseContainsEdge snapshot edge =+  U.elem+    (edgeTarget edge)+    (csrTargetsForKey (graphForward (frozenBase snapshot)) (edgeSource edge))++overlayContainsEdge :: GraphSnapshot -> Edge -> Bool+overlayContainsEdge snapshot edge =+  IntSet.member+    (edgeTarget edge)+    (IntMap.findWithDefault IntSet.empty (edgeSource edge) (insertedEdgeOverlay snapshot))++edgeTombstoned :: GraphSnapshot -> Edge -> Bool+edgeTombstoned snapshot edge =+  Set.member edge (unEdgeTombstones (deletedEdges snapshot))++compactSnapshot :: GraphSnapshot -> GraphSnapshot+compactSnapshot snapshot =+  compactAtEpoch (epoch snapshot + 1) snapshot++compactIfNeeded :: GraphSnapshot -> GraphSnapshot+compactIfNeeded snapshot+  | needsCompaction snapshot =+      compactAtEpoch (epoch snapshot) snapshot+  | otherwise =+      snapshot+{-# INLINE compactIfNeeded #-}++needsCompaction :: GraphSnapshot -> Bool+needsCompaction snapshot =+  overlayEdgeCount snapshot + tombstoneCount snapshot+    > max 1 (baseEdgeCount snapshot `quot` compactionDivisor)+{-# INLINE needsCompaction #-}++compactionDivisor :: Int+compactionDivisor =+  10+{-# INLINE compactionDivisor #-}++baseEdgeCount :: GraphSnapshot -> Int+baseEdgeCount =+  U.length . csrTargets . graphForward . frozenBase+{-# INLINE baseEdgeCount #-}++overlayEdgeCount :: GraphSnapshot -> Int+overlayEdgeCount =+  IntMap.foldl' (\count targets -> count + IntSet.size targets) 0 . insertedEdgeOverlay+{-# INLINE overlayEdgeCount #-}++tombstoneCount :: GraphSnapshot -> Int+tombstoneCount (GraphSnapshot {deletedEdges = EdgeTombstones tombstones}) =+  Set.size tombstones+{-# INLINE tombstoneCount #-}++compactAtEpoch :: Int -> GraphSnapshot -> GraphSnapshot+compactAtEpoch epochValue snapshot =+  GraphSnapshot+    { frozenBase = frozenDigraphFromSuccessors vertexCount (successors snapshot),+      insertedEdgeOverlay = IntMap.empty,+      deletedEdges = emptyEdgeTombstones,+      epoch = epochValue+    }+  where+    vertexCount =+      csrVertexCount (graphForward (frozenBase snapshot))+{-# INLINE compactAtEpoch #-}++edgeLive :: GraphSnapshot -> Int -> Int -> Bool+edgeLive snapshot source target =+  inBounds (csrVertexCount (graphForward (frozenBase snapshot))) target+    && not (Set.member (Edge source target) tombstones)+  where+    EdgeTombstones tombstones =+      deletedEdges snapshot+{-# INLINE edgeLive #-}++successors :: GraphSnapshot -> Int -> IntSet+successors snapshot source =+  IntSet.filter+    (\target -> inBounds vertexCount target && not (tombstoned target))+    ( IntSet.union+        (csrTargetsSet (graphForward (frozenBase snapshot)) source)+        (IntMap.findWithDefault IntSet.empty source (insertedEdgeOverlay snapshot))+    )+  where+    vertexCount =+      csrVertexCount (graphForward (frozenBase snapshot))+    EdgeTombstones tombstones =+      deletedEdges snapshot+    tombstoned target =+      Set.member (Edge source target) tombstones++insertTombstone :: Edge -> EdgeTombstones -> EdgeTombstones+insertTombstone edge (EdgeTombstones tombstones) =+  EdgeTombstones (Set.insert edge tombstones)++deleteTombstone :: Edge -> EdgeTombstones -> EdgeTombstones+deleteTombstone edge (EdgeTombstones tombstones) =+  EdgeTombstones (Set.delete edge tombstones)++keepNonEmptyIntSet :: IntSet -> Maybe IntSet+keepNonEmptyIntSet values+  | IntSet.null values = Nothing+  | otherwise = Just values
+ src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Traverse.hs view
@@ -0,0 +1,371 @@+-- | The adaptive sparse-push/dense-pull reachability engine and its @runST@+-- seals. Direction is chosen per frontier by work estimates; frozen digraphs+-- traverse the SCC condensation, snapshots traverse the live overlay. The four+-- public entry points are the only openings of 'runST' in the Dense kernel.+module Moonlight.Core.Fixpoint.Dense.Internal.Traverse+  ( frozenReachabilityFrom,+    frozenReachabilityWithPolicy,+    frozenReachabilityWithCache,+    snapshotReachabilityFrom,+  )+where++import Control.Monad.ST (ST, runST)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Set qualified as Set+import Data.Vector.Unboxed (Vector)+import Data.Vector.Unboxed qualified as U+import Data.Word (Word32)+import Moonlight.Core.Fixpoint.Dense.Internal.ClosureCache+  ( SccClosureCache,+    closeComponents,+    closureCacheGraph,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.Csr+  ( GraphCsr,+    csrOutDegree,+    csrTargetsForKey,+    csrVertexCount,+    inBounds,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.Policy+  ( ReachabilityPolicy (..),+    defaultReachabilityPolicy,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.Scc+  ( FrozenDigraph (..),+    SccPlan (..),+    expandComponents,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.Scratch+  ( Frontier (..),+    ReachabilityScratch,+    ScratchSide (..),+    appendFreshTarget,+    appendSparseBuffer,+    flipScratchSide,+    frontierContainsAnyM,+    frontierEmpty,+    frontierFoldM',+    frontierMemberM,+    frontierSize,+    isMarked,+    markVectorFresh,+    markVisited,+    newReachabilityScratch,+    nextReachabilityGeneration,+    strictFoldM,+    visitedMarksToIntSet,+    writeDenseFrontierM,+  )+import Moonlight.Core.Fixpoint.Dense.Internal.Snapshot+  ( EdgeTombstones (..),+    GraphSnapshot (..),+    edgeLive,+  )+import Prelude++frozenReachabilityFrom :: FrozenDigraph -> IntSet -> IntSet+frozenReachabilityFrom =+  frozenReachabilityWithPolicy defaultReachabilityPolicy+{-# INLINE frozenReachabilityFrom #-}++frozenReachabilityWithPolicy :: ReachabilityPolicy -> FrozenDigraph -> IntSet -> IntSet+frozenReachabilityWithPolicy policy graph seeds =+  expandComponents plan reachedComponents+  where+    plan = graphSccPlan graph+    seedComponents =+      IntSet.fromList+        [ component+          | v <- IntSet.toAscList (IntSet.filter (inBounds (csrVertexCount (graphForward graph))) seeds),+            Just component <- [sccOfVertex plan U.!? v]+        ]+    reachedComponents =+      adaptiveReachability policy (condensation plan) (condensationBackward plan) seedComponents+{-# INLINE frozenReachabilityWithPolicy #-}++frozenReachabilityWithCache ::+  SccClosureCache ->+  IntSet ->+  (IntSet, SccClosureCache)+frozenReachabilityWithCache cache seeds =+  (expandComponents plan reachedComponents, nextCache)+  where+    plan =+      graphSccPlan graph+    graph =+      closureCacheGraph cache+    seedComponents =+      IntSet.fromList+        [ component+          | v <- IntSet.toAscList (IntSet.filter (inBounds (csrVertexCount (graphForward graph))) seeds),+            Just component <- [sccOfVertex plan U.!? v]+        ]+    (reachedComponents, nextCache) =+      closeComponents seedComponents cache++snapshotReachabilityFrom :: GraphSnapshot -> IntSet -> IntSet+snapshotReachabilityFrom snapshot seeds+  | IntMap.null (insertedEdgeOverlay snapshot) && Set.null tombstones =+      frozenReachabilityFrom (frozenBase snapshot) seeds+  | otherwise =+      snapshotReachabilityWithPolicy defaultReachabilityPolicy snapshot seeds+  where+    tombstones =+      unEdgeTombstones (deletedEdges snapshot)++adaptiveReachability :: ReachabilityPolicy -> GraphCsr -> GraphCsr -> IntSet -> IntSet+adaptiveReachability policy forward backward seeds =+  runST $ do+    scratch <- newReachabilityScratch (csrVertexCount forward)+    adaptiveReachabilityWithScratch policy forward backward scratch seeds+{-# INLINE adaptiveReachability #-}++snapshotReachabilityWithPolicy :: ReachabilityPolicy -> GraphSnapshot -> IntSet -> IntSet+snapshotReachabilityWithPolicy policy snapshot seeds =+  runST $ do+    scratch <- newReachabilityScratch vertexCount+    generation <- nextReachabilityGeneration scratch+    seedLength <- markVectorFresh scratch generation ScratchA boundedSeedVector+    frontier <- frontierFromSparseM policy scratch ScratchA ScratchA seedLength+    let advanceFrontier currentFrontier targetSide = do+          pull <- useSnapshotPullM policy snapshot scratch generation currentFrontier+          if pull+            then snapshotDensePullM snapshot scratch generation currentFrontier targetSide+            else snapshotSparsePushM snapshot scratch generation currentFrontier targetSide+    traverseFrontiersWith policy scratch advanceFrontier frontier ScratchB ScratchB+    visitedMarksToIntSet scratch generation+  where+    vertexCount =+      csrVertexCount (graphForward (frozenBase snapshot))+    boundedSeedVector =+      U.fromList (IntSet.toAscList (IntSet.filter (inBounds vertexCount) seeds))+{-# INLINE snapshotReachabilityWithPolicy #-}++adaptiveReachabilityWithScratch :: ReachabilityPolicy -> GraphCsr -> GraphCsr -> ReachabilityScratch state -> IntSet -> ST state IntSet+adaptiveReachabilityWithScratch policy forward backward scratch seeds = do+  generation <- nextReachabilityGeneration scratch+  seedLength <- markVectorFresh scratch generation ScratchA boundedSeedVector+  frontier <- frontierFromSparseM policy scratch ScratchA ScratchA seedLength+  let advanceFrontier currentFrontier targetSide = do+        pull <- usePullM policy forward backward scratch generation currentFrontier+        if pull+          then densePullM backward scratch generation currentFrontier targetSide+          else sparsePushM forward scratch generation currentFrontier targetSide+  traverseFrontiersWith policy scratch advanceFrontier frontier ScratchB ScratchB+  visitedMarksToIntSet scratch generation+  where+    boundedSeedVector =+      U.fromList (IntSet.toAscList (IntSet.filter (inBounds (csrVertexCount forward)) seeds))+{-# INLINE adaptiveReachabilityWithScratch #-}++traverseFrontiersWith ::+  ReachabilityPolicy ->+  ReachabilityScratch state ->+  (Frontier -> ScratchSide -> ST state Int) ->+  Frontier ->+  ScratchSide ->+  ScratchSide ->+  ST state ()+traverseFrontiersWith policy scratch advanceFrontier frontier nextSparseSide nextDenseSide+  | frontierEmpty frontier = pure ()+  | otherwise = do+      nextLength <- advanceFrontier frontier nextSparseSide+      nextFrontier <- frontierFromSparseM policy scratch nextSparseSide nextDenseSide nextLength+      traverseFrontiersWith+        policy+        scratch+        advanceFrontier+        nextFrontier+        (flipScratchSide nextSparseSide)+        (flipScratchSide nextDenseSide)+{-# INLINE traverseFrontiersWith #-}++usePullM :: ReachabilityPolicy -> GraphCsr -> GraphCsr -> ReachabilityScratch state -> Word32 -> Frontier -> ST state Bool+usePullM policy forward backward scratch generation frontier+  | frontierSize frontier <= smallFrontierLimit policy = pure False+  | otherwise = do+      pullWork <- max 1 <$> unvisitedIncomingWorkM backward scratch generation+      pushWork <- frontierWorkM forward scratch frontier+      pure (fromIntegral pushWork > frontierPullThreshold policy frontier * fromIntegral pullWork)+{-# INLINE usePullM #-}++useSnapshotPullM :: ReachabilityPolicy -> GraphSnapshot -> ReachabilityScratch state -> Word32 -> Frontier -> ST state Bool+useSnapshotPullM policy snapshot =+  usePullM policy (graphForward (frozenBase snapshot)) (graphBackward (frozenBase snapshot))+{-# INLINE useSnapshotPullM #-}++frontierPullThreshold :: ReachabilityPolicy -> Frontier -> Double+frontierPullThreshold policy frontier =+  case frontier of+    SparseFrontier _ _ ->+      pushToPullRatio policy+    DenseFrontier _ _ ->+      pullToPushRatio policy+{-# INLINE frontierPullThreshold #-}++frontierFromSparseM :: ReachabilityPolicy -> ReachabilityScratch state -> ScratchSide -> ScratchSide -> Int -> ST state Frontier+frontierFromSparseM policy scratch sparseSide denseSide frontierLength+  | frontierLength <= smallFrontierLimit policy = pure (SparseFrontier sparseSide frontierLength)+  | otherwise = do+      writeDenseFrontierM scratch sparseSide denseSide frontierLength+      pure (DenseFrontier denseSide frontierLength)+{-# INLINE frontierFromSparseM #-}++frontierWorkM :: GraphCsr -> ReachabilityScratch state -> Frontier -> ST state Int+frontierWorkM csr scratch =+  frontierFoldM' scratch (\acc v -> pure (acc + csrOutDegree csr v)) 0+{-# INLINE frontierWorkM #-}++unvisitedIncomingWorkM :: GraphCsr -> ReachabilityScratch state -> Word32 -> ST state Int+unvisitedIncomingWorkM backward scratch generation =+  strictFoldM step 0 [0 .. csrVertexCount backward - 1]+  where+    step acc vertex = do+      seen <- isMarked scratch generation vertex+      pure (if seen then acc else acc + csrOutDegree backward vertex)+{-# INLINE unvisitedIncomingWorkM #-}++sparsePushM :: GraphCsr -> ReachabilityScratch state -> Word32 -> Frontier -> ScratchSide -> ST state Int+sparsePushM forward scratch generation frontier targetSide =+  frontierFoldM'+    scratch+    ( \fresh source ->+        U.foldM'+          (appendFreshTarget scratch generation targetSide)+          fresh+          (csrTargetsForKey forward source)+    )+    0+    frontier+{-# INLINE sparsePushM #-}++snapshotSparsePushM :: GraphSnapshot -> ReachabilityScratch state -> Word32 -> Frontier -> ScratchSide -> ST state Int+snapshotSparsePushM snapshot scratch generation frontier targetSide =+  frontierFoldM'+    scratch+    (appendFreshSnapshotTargets snapshot scratch generation targetSide)+    0+    frontier+{-# INLINE snapshotSparsePushM #-}++snapshotDensePullM :: GraphSnapshot -> ReachabilityScratch state -> Word32 -> Frontier -> ScratchSide -> ST state Int+snapshotDensePullM snapshot scratch generation frontier targetSide = do+  baseFreshLength <- snapshotDenseBasePullM snapshot scratch generation frontier targetSide+  snapshotOverlayPushM snapshot scratch generation frontier targetSide baseFreshLength+{-# INLINE snapshotDensePullM #-}++snapshotDenseBasePullM :: GraphSnapshot -> ReachabilityScratch state -> Word32 -> Frontier -> ScratchSide -> ST state Int+snapshotDenseBasePullM snapshot scratch generation frontier targetSide =+  strictFoldM step 0 [0 .. csrVertexCount backward - 1]+  where+    backward =+      graphBackward (frozenBase snapshot)++    step freshLength target = do+      seen <- isMarked scratch generation target+      if seen+        then pure freshLength+        else do+          reached <- frontierContainsAnyLiveBaseIncomingM snapshot scratch frontier target (csrTargetsForKey backward target)+          if reached+            then markVisited scratch generation target *> appendSparseBuffer scratch targetSide freshLength target+            else pure freshLength+{-# INLINE snapshotDenseBasePullM #-}++frontierContainsAnyLiveBaseIncomingM ::+  GraphSnapshot ->+  ReachabilityScratch state ->+  Frontier ->+  Int ->+  Vector Int ->+  ST state Bool+frontierContainsAnyLiveBaseIncomingM snapshot scratch frontier target =+  U.foldr+    ( \source remaining ->+        if edgeLive snapshot source target+          then do+            found <- frontierMemberM scratch frontier source+            if found then pure True else remaining+          else remaining+    )+    (pure False)+{-# INLINE frontierContainsAnyLiveBaseIncomingM #-}++snapshotOverlayPushM :: GraphSnapshot -> ReachabilityScratch state -> Word32 -> Frontier -> ScratchSide -> Int -> ST state Int+snapshotOverlayPushM snapshot scratch generation frontier targetSide initialFreshLength =+  frontierFoldM'+    scratch+    (appendFreshSnapshotOverlayTargets snapshot scratch generation targetSide)+    initialFreshLength+    frontier+{-# INLINE snapshotOverlayPushM #-}++appendFreshSnapshotOverlayTargets ::+  GraphSnapshot ->+  ReachabilityScratch state ->+  Word32 ->+  ScratchSide ->+  Int ->+  Int ->+  ST state Int+appendFreshSnapshotOverlayTargets snapshot scratch generation targetSide freshLength source =+  strictFoldM+    (appendLiveSnapshotTarget snapshot scratch generation targetSide source)+    freshLength+    (IntSet.toAscList (IntMap.findWithDefault IntSet.empty source (insertedEdgeOverlay snapshot)))+{-# INLINE appendFreshSnapshotOverlayTargets #-}++appendFreshSnapshotTargets ::+  GraphSnapshot ->+  ReachabilityScratch state ->+  Word32 ->+  ScratchSide ->+  Int ->+  Int ->+  ST state Int+appendFreshSnapshotTargets snapshot scratch generation targetSide freshLength source = do+  baseFreshLength <-+    U.foldM'+      (appendLiveSnapshotTarget snapshot scratch generation targetSide source)+      freshLength+      (csrTargetsForKey (graphForward (frozenBase snapshot)) source)+  strictFoldM+    (appendLiveSnapshotTarget snapshot scratch generation targetSide source)+    baseFreshLength+    (IntSet.toAscList (IntMap.findWithDefault IntSet.empty source (insertedEdgeOverlay snapshot)))+{-# INLINE appendFreshSnapshotTargets #-}++appendLiveSnapshotTarget ::+  GraphSnapshot ->+  ReachabilityScratch state ->+  Word32 ->+  ScratchSide ->+  Int ->+  Int ->+  Int ->+  ST state Int+appendLiveSnapshotTarget snapshot scratch generation targetSide source freshLength target+  | edgeLive snapshot source target =+      appendFreshTarget scratch generation targetSide freshLength target+  | otherwise =+      pure freshLength+{-# INLINE appendLiveSnapshotTarget #-}++densePullM :: GraphCsr -> ReachabilityScratch state -> Word32 -> Frontier -> ScratchSide -> ST state Int+densePullM backward scratch generation frontier targetSide =+  strictFoldM step 0 [0 .. csrVertexCount backward - 1]+  where+    step freshLength vertex = do+      seen <- isMarked scratch generation vertex+      if seen+        then pure freshLength+        else do+          reached <- frontierContainsAnyM scratch frontier (csrTargetsForKey backward vertex)+          if reached+            then markVisited scratch generation vertex *> appendSparseBuffer scratch targetSide freshLength vertex+            else pure freshLength+{-# INLINE densePullM #-}
+ src-solver/Moonlight/Core/Fixpoint/Internal/Combinators.hs view
@@ -0,0 +1,147 @@+-- | Bounded fixpoint iteration, once-only integer worklists, and transitive+-- closure. Pure combinators over 'Moonlight.Core.Queue'; no mutation.+module Moonlight.Core.Fixpoint.Internal.Combinators+  ( FixpointDivergence (..),+    fixpointBounded,+    fixpointBoundedM,+    worklistFold,+    traverseOnceIntSet,+    reschedulingWorklistFoldIntSet,+    closureUnder,+    closureUnderInt,+    reachabilityFrom,+    reachabilityFromInt,+  )+where++import Data.Functor.Identity (Identity (..), runIdentity)+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Set (Set)+import Data.Set qualified as Set+import Moonlight.Core.Queue (Queue, dequeue, enqueueAll, queueFromList)+import Numeric.Natural (Natural)+import Prelude++data FixpointDivergence a = FixpointDivergence+  { fixpointDivergenceBudget :: !Natural,+    fixpointDivergenceLast :: !a+  }+  deriving stock (Eq, Ord, Show, Read)++fixpointBounded :: Eq a => Natural -> (a -> a) -> a -> Either (FixpointDivergence a) a+fixpointBounded budget step =+  runIdentity . fixpointBoundedM budget (Identity . step)++fixpointBoundedM :: (Monad m, Eq a) => Natural -> (a -> m a) -> a -> m (Either (FixpointDivergence a) a)+fixpointBoundedM budget =+  fixpointBoundedWorker budget budget++fixpointBoundedWorker ::+  (Monad m, Eq a) =>+  Natural ->+  Natural ->+  (a -> m a) ->+  a ->+  m (Either (FixpointDivergence a) a)+fixpointBoundedWorker budget remaining step current+  | remaining == 0 = pure (Left (FixpointDivergence budget current))+  | otherwise = do+      next <- step current+      if next == current+        then pure (Right current)+        else fixpointBoundedWorker budget (remaining - 1) step next++worklistFold :: (state -> item -> (state, [item])) -> state -> Queue item -> state+worklistFold step state frontier =+  case dequeue frontier of+    Nothing -> state+    Just (item, remainingFrontier) ->+      case step state item of+        (nextState, queuedItems) ->+          nextState `seq` worklistFold step nextState (enqueueAll queuedItems remainingFrontier)++-- | Reachability primitive: each integer key is expanded at most once.+traverseOnceIntSet :: (state -> Int -> (state, IntSet)) -> state -> IntSet -> state+traverseOnceIntSet step =+  freshIntSetWorklist step IntSet.empty++-- | Fixpoint-style integer worklist: an item may run again after it has been+-- dequeued, but duplicate queued copies are collapsed while it is waiting.+reschedulingWorklistFoldIntSet :: (state -> Int -> (state, IntSet)) -> state -> IntSet -> state+reschedulingWorklistFoldIntSet step initialState initialFrontier =+  reschedulingIntSetWorklist+    step+    initialState+    (queueFromList (IntSet.toAscList initialFrontier))+    initialFrontier++reschedulingIntSetWorklist ::+  (state -> Int -> (state, IntSet)) ->+  state ->+  Queue Int ->+  IntSet ->+  state+reschedulingIntSetWorklist step state frontier queued =+  case dequeue frontier of+    Nothing ->+      state+    Just (item, remainingFrontier) ->+      let queuedAfterPop =+            IntSet.delete item queued+       in case step state item of+            (nextState, requestedItems) ->+              let freshItems =+                    IntSet.difference requestedItems queuedAfterPop+               in nextState `seq`+                    reschedulingIntSetWorklist+                      step+                      nextState+                      (enqueueAll (IntSet.toAscList freshItems) remainingFrontier)+                      (IntSet.union queuedAfterPop freshItems)++freshIntSetWorklist :: (state -> Int -> (state, IntSet)) -> IntSet -> state -> IntSet -> state+freshIntSetWorklist step processed state frontier =+  case IntSet.minView frontier of+    Nothing -> state+    Just (item, rest)+      | IntSet.member item processed ->+          freshIntSetWorklist step processed state rest+      | otherwise ->+          case step state item of+            (nextState, queued) ->+              let nextProcessed = IntSet.insert item processed+               in nextState `seq`+                    freshIntSetWorklist+                      step+                      nextProcessed+                      nextState+                      (IntSet.union rest (IntSet.difference queued nextProcessed))++closureUnder :: Ord value => (value -> Set value) -> Set value -> Set value+closureUnder =+  reachabilityFrom++closureUnderInt :: (Int -> IntSet) -> IntSet -> IntSet+closureUnderInt =+  reachabilityFromInt++reachabilityFrom :: Ord value => (value -> Set value) -> Set value -> Set value+reachabilityFrom expand seeds =+  worklistClosureSet expand seeds (queueFromList (Set.toAscList seeds))++reachabilityFromInt :: (Int -> IntSet) -> IntSet -> IntSet+reachabilityFromInt expand seeds =+  traverseOnceIntSet step seeds seeds+  where+    step visited value =+      let freshValues = IntSet.difference (expand value) visited+       in (IntSet.union visited freshValues, freshValues)++worklistClosureSet :: Ord value => (value -> Set value) -> Set value -> Queue value -> Set value+worklistClosureSet expand =+  worklistFold step+  where+    step visited value =+      let freshValues = Set.difference (expand value) visited+       in (Set.union visited freshValues, Set.toAscList freshValues)
+ src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Arena.hs view
@@ -0,0 +1,91 @@+-- | The mutable solver arena: value cells plus pending-delta accumulators,+-- with seeding, delta bookkeeping, direct evaluation, and result extraction.+module Moonlight.Core.Fixpoint.Internal.Solver.Arena+  ( Arena (..),+    new,+    seed,+    seedDeltaM,+    evaluate,+    toResult,+    takePendingDelta,+    mergePendingDelta,+  )+where++import Control.Applicative.Free (runAp)+import Control.Monad.ST (ST)+import Data.Foldable (traverse_)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Vector qualified as Vector+import Data.Vector.Mutable qualified as MVector+import Moonlight.Core.Fixpoint.Internal.Solver.Types+  ( DeltaDomain (..),+    EquationId (..),+    EquationRead (..),+    Evaluation (..),+    Result (..),+    Snapshot (..),+  )+import Prelude++data Arena state value delta = Arena+  { values :: !(MVector.MVector state value),+    pending :: !(MVector.MVector state delta)+  }++new :: DeltaDomain value delta -> Snapshot value delta -> ST state (Arena state value delta)+new domain snapshot = do+  values <- Vector.thaw (snapshotValues snapshot)+  pending <- MVector.replicate (Vector.length (snapshotValues snapshot)) (deltaEmpty domain)+  pure+    Arena+      { values = values,+        pending = pending+      }++seed :: DeltaDomain value delta -> Arena state value delta -> IntMap delta -> ST state ()+seed domain arena =+  traverse_ (uncurry (seedDeltaM domain arena)) . IntMap.toAscList++seedDeltaM :: DeltaDomain value delta -> Arena state value delta -> Int -> delta -> ST state Bool+seedDeltaM domain arena key deltaValue+  | deltaNull domain deltaValue = pure False+  | otherwise = do+      oldValue <- MVector.read (values arena) key+      let candidateValue = deltaApply domain deltaValue oldValue+          effectiveDelta = deltaBetween domain oldValue candidateValue+      if deltaNull domain effectiveDelta+        then pure False+        else do+          MVector.write (values arena) key candidateValue+          mergePendingDelta domain arena key effectiveDelta+          pure True++evaluate :: Arena state value delta -> Evaluation value result -> ST state result+evaluate arena (Evaluation program) =+  runAp (interpretRead arena) program++interpretRead :: Arena state value delta -> EquationRead value result -> ST state result+interpretRead arena (ReadEquationValue (EquationId key))+  = MVector.read (values arena) key++toResult :: Arena state value delta -> ST state (Result value delta)+toResult arena = do+  values <- Vector.freeze (values arena)+  pure+    Result+      { resultValues = values,+        resultSnapshot = Snapshot values+      }++takePendingDelta :: DeltaDomain value delta -> Arena state value delta -> Int -> ST state delta+takePendingDelta domain arena key = do+  deltaValue <- MVector.read (pending arena) key+  MVector.write (pending arena) key (deltaEmpty domain)+  pure deltaValue++mergePendingDelta :: DeltaDomain value delta -> Arena state value delta -> Int -> delta -> ST state ()+mergePendingDelta domain arena key deltaValue = do+  oldPending <- MVector.read (pending arena) key+  MVector.write (pending arena) key (deltaMerge domain oldPending deltaValue)
+ src-solver/Moonlight/Core/Fixpoint/Internal/Solver/BitSet.hs view
@@ -0,0 +1,75 @@+-- | A mutable @Word64@-packed bit set over a bounded non-negative key range.+module Moonlight.Core.Fixpoint.Internal.Solver.BitSet+  ( MutableBitSet (..),+    newBitSet,+    bitSetMember,+    bitSetInsert,+    bitSetDelete,+  )+where++import Control.Monad.ST (ST)+import Data.Bits (clearBit, setBit, testBit)+import Data.Vector.Unboxed.Mutable qualified as UMVector+import Data.Word (Word64)+import Prelude++data MutableBitSet state = MutableBitSet+  { size :: !Int,+    bitSetWords :: !(UMVector.MVector state Word64)+  }++newBitSet :: Int -> ST state (MutableBitSet state)+newBitSet size = do+  wordsVector <- UMVector.replicate wordCount 0+  pure+    MutableBitSet+      { size = max 0 size,+        bitSetWords = wordsVector+      }+  where+    wordCount =+      (max 0 size + bitSetWordBits - 1) `quot` bitSetWordBits++bitSetMember :: Int -> MutableBitSet state -> ST state Bool+bitSetMember key bitSet+  | not (bitSetInBounds key bitSet) = pure False+  | otherwise = do+      word <- UMVector.read (bitSetWords bitSet) (bitSetWordIndex key)+      pure (testBit word (bitSetBitIndex key))++bitSetInsert :: Int -> MutableBitSet state -> ST state ()+bitSetInsert key bitSet+  | not (bitSetInBounds key bitSet) = pure ()+  | otherwise =+      modifyBitSetWord key (`setBit` bitSetBitIndex key) bitSet++bitSetDelete :: Int -> MutableBitSet state -> ST state ()+bitSetDelete key bitSet+  | not (bitSetInBounds key bitSet) = pure ()+  | otherwise =+      modifyBitSetWord key (`clearBit` bitSetBitIndex key) bitSet++modifyBitSetWord :: Int -> (Word64 -> Word64) -> MutableBitSet state -> ST state ()+modifyBitSetWord key update bitSet = do+  word <- UMVector.read (bitSetWords bitSet) wordIndex+  UMVector.write (bitSetWords bitSet) wordIndex (update word)+  where+    wordIndex =+      bitSetWordIndex key++bitSetInBounds :: Int -> MutableBitSet state -> Bool+bitSetInBounds key bitSet =+  key >= 0 && key < size bitSet++bitSetWordIndex :: Int -> Int+bitSetWordIndex key =+  key `quot` bitSetWordBits++bitSetBitIndex :: Int -> Int+bitSetBitIndex key =+  key `rem` bitSetWordBits++bitSetWordBits :: Int+bitSetWordBits =+  64
+ src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Engine.hs view
@@ -0,0 +1,303 @@+-- | The monotone solving engine: arena-based equation evaluation, acyclic and+-- cyclic component solving, widening/narrowing, and the public @solve*@ entry+-- points — the only @runST@ seals over the private arena/queue/bitset.+module Moonlight.Core.Fixpoint.Internal.Solver.Engine+  ( solveMonotone,+    solveDenseMonotone,+    solveIncremental,+  )+where++import Control.Monad (void, when)+import Control.Monad.ST (ST, runST)+import Data.Foldable (traverse_)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import Data.Vector.Mutable qualified as MVector+import Moonlight.Core.Fixpoint.Internal.Solver.Arena qualified as Arena+import Moonlight.Core.Fixpoint.Internal.Solver.Plan+  ( dense,+    equationsForOutput,+    equationsUsingInput,+    validateDeltas,+    validateSnapshot,+  )+import Moonlight.Core.Fixpoint.Internal.Solver.Types+  ( ConvergencePlan (..),+    DeltaDomain (..),+    Equation (..),+    EquationId (..),+    Evaluation,+    OutputUpdate,+    Component (..),+    Obstruction,+    Plan (..),+    Result,+    Snapshot (..),+    WideningPolicy (..),+    equationIdKey,+  )+import Moonlight.Core.Fixpoint.Internal.Solver.WorkQueue qualified as WorkQueue+import Prelude++solveMonotone :: DeltaDomain value delta -> Plan value delta -> Vector value -> Either Obstruction (Result value delta)+solveMonotone domain plan values =+  validateSnapshot plan snapshot+    *> pure (solveFullSnapshot domain plan snapshot)+  where+    snapshot =+      Snapshot values++solveDenseMonotone ::+  DeltaDomain value delta ->+  Int ->+  (Int -> Evaluation value value) ->+  (Int -> value) ->+  Either Obstruction (Result value delta)+solveDenseMonotone domain valueCount evaluate initialValue =+  dense count evaluate+    >>= \plan ->+      pure+        ( runST $ do+            arena <- Arena.new domain snapshot+            traverse_ (solveComponentM domain plan arena) (components plan)+            Arena.toResult arena+        )+  where+    count =+      max 0 valueCount+    snapshot =+      Snapshot (Vector.generate count initialValue)++solveIncremental ::+  DeltaDomain value delta ->+  Plan value delta ->+  Snapshot value delta ->+  IntMap delta ->+  Either Obstruction (Result value delta)+solveIncremental domain plan snapshot deltas =+  validateSnapshot plan snapshot+    *> validateDeltas domain plan deltas+    *> pure+      ( runST $ do+          arena <- Arena.new domain snapshot+          case convergencePlan plan of+            FiniteHeightScc ->+              solveFiniteIncrementalM domain plan arena deltas+            Widening {} ->+              Arena.seed domain arena deltas+                *> traverse_ (solveComponentM domain plan arena) (components plan)+          Arena.toResult arena+      )++solveFullSnapshot :: DeltaDomain value delta -> Plan value delta -> Snapshot value delta -> Result value delta+solveFullSnapshot domain plan snapshot =+  runST $ do+    arena <- Arena.new domain snapshot+    traverse_ (solveComponentM domain plan arena) (components plan)+    Arena.toResult arena+{-# INLINE solveFullSnapshot #-}++solveFiniteIncrementalM ::+  DeltaDomain value delta ->+  Plan value delta ->+  Arena.Arena state value delta ->+  IntMap delta ->+  ST state ()+solveFiniteIncrementalM domain plan arena deltas = do+  queue <- WorkQueue.new (MVector.length (Arena.values arena))+  seedQueued domain arena queue deltas+  WorkQueue.drain queue (evaluatePendingInputM finiteOutputUpdate domain plan arena queue)+{-# INLINE solveFiniteIncrementalM #-}++seedQueued ::+  DeltaDomain value delta ->+  Arena.Arena state value delta ->+  WorkQueue.WorkQueue state ->+  IntMap delta ->+  ST state ()+seedQueued domain arena queue =+  traverse_ (uncurry seedQueuedDelta) . IntMap.toAscList+  where+    seedQueuedDelta key deltaValue+      | deltaNull domain deltaValue = pure ()+      | otherwise = do+          changed <- Arena.seedDeltaM domain arena key deltaValue+          when changed (WorkQueue.enqueue queue key)+{-# INLINE seedQueued #-}++solveComponentM :: DeltaDomain value delta -> Plan value delta -> Arena.Arena state value delta -> Component -> ST state ()+solveComponentM domain plan arena component =+  case component of+    AcyclicOutput output ->+      traverse_ (evaluateFullEquationM domain arena) (equationsForOutput output plan)+    CyclicOutputs outputs ->+      solveCyclicComponentM domain plan arena outputs++solveCyclicComponentM :: DeltaDomain value delta -> Plan value delta -> Arena.Arena state value delta -> IntSet -> ST state ()+solveCyclicComponentM domain plan arena outputs = do+  queue <- WorkQueue.new (MVector.length (Arena.values arena))+  seedCyclicComponentM widenOutput domain plan arena outputs queue+  WorkQueue.drain queue (evaluateCyclicInputM widenOutput domain plan arena outputs queue)+  narrowCyclicComponentM (convergencePlan plan) domain plan arena outputs+  where+    widenOutput =+      convergenceWidenOutput (convergencePlan plan) outputs++finiteOutputUpdate :: OutputUpdate value+finiteOutputUpdate _ _ newValue =+  newValue++convergenceWidenOutput :: ConvergencePlan value -> IntSet -> OutputUpdate value+convergenceWidenOutput convergence outputs =+  case convergence of+    FiniteHeightScc ->+      finiteOutputUpdate+    Widening policy ->+      headedOutputUpdate (IntSet.intersection (wideningHeads policy) outputs) (widenAt policy)++narrowCyclicComponentM ::+  ConvergencePlan value ->+  DeltaDomain value delta ->+  Plan value delta ->+  Arena.Arena state value delta ->+  IntSet ->+  ST state ()+narrowCyclicComponentM convergence domain plan arena outputs =+  case convergence of+    FiniteHeightScc ->+      pure ()+    Widening policy+      | IntSet.null componentHeads ->+          pure ()+      | otherwise -> do+          queue <- WorkQueue.new (MVector.length (Arena.values arena))+          seedCyclicComponentM narrowOutput domain plan arena outputs queue+          WorkQueue.drain queue (evaluateCyclicInputM narrowOutput domain plan arena outputs queue)+      where+        componentHeads =+          IntSet.intersection (wideningHeads policy) outputs+        narrowOutput =+          headedOutputUpdate componentHeads (narrowAt policy)++headedOutputUpdate :: IntSet -> (Int -> value -> value -> value) -> OutputUpdate value+headedOutputUpdate heads update key oldValue newValue+  | IntSet.member key heads =+      update key oldValue newValue+  | otherwise =+      newValue++seedCyclicComponentM ::+  OutputUpdate value ->+  DeltaDomain value delta ->+  Plan value delta ->+  Arena.Arena state value delta ->+  IntSet ->+  WorkQueue.WorkQueue state ->+  ST state ()+seedCyclicComponentM updateOutput domain plan arena outputs queue =+  traverse_ seedOutput (IntSet.toAscList outputs)+  where+    seedOutput outputKey =+      traverse_ seedEquation (equationsForOutput (EquationId outputKey) plan)+    seedEquation equation = do+      changed <- evaluateFullEquationChangedWithM updateOutput domain arena equation+      if changed+        then WorkQueue.enqueue queue (equationIdKey (equationOutput equation))+        else pure ()++evaluateCyclicInputM ::+  OutputUpdate value ->+  DeltaDomain value delta ->+  Plan value delta ->+  Arena.Arena state value delta ->+  IntSet ->+  WorkQueue.WorkQueue state ->+  Int ->+  ST state ()+evaluateCyclicInputM updateOutput domain plan arena componentOutputs queue inputKey = do+  inputDelta <- Arena.takePendingDelta domain arena inputKey+  traverse_ (step inputDelta) relevantEquations+  where+    input = EquationId inputKey+    relevantEquations =+      filter ((`IntSet.member` componentOutputs) . unEquationId . equationOutput) (equationsUsingInput input plan)+    step inputDelta equation = do+      changed <- evaluateEquationForInputM updateOutput domain arena input inputDelta equation+      if changed+        then WorkQueue.enqueue queue (equationIdKey (equationOutput equation))+        else pure ()++evaluatePendingInputM ::+  OutputUpdate value ->+  DeltaDomain value delta ->+  Plan value delta ->+  Arena.Arena state value delta ->+  WorkQueue.WorkQueue state ->+  Int ->+  ST state ()+evaluatePendingInputM updateOutput domain plan arena queue inputKey = do+  inputDelta <- Arena.takePendingDelta domain arena inputKey+  traverse_ (step inputDelta) (equationsUsingInput input plan)+  where+    input =+      EquationId inputKey+    step inputDelta equation = do+      changed <- evaluateEquationForInputM updateOutput domain arena input inputDelta equation+      if changed+        then WorkQueue.enqueue queue (equationIdKey (equationOutput equation))+        else pure ()+{-# INLINE evaluatePendingInputM #-}++evaluateEquationForInputM ::+  OutputUpdate value ->+  DeltaDomain value delta ->+  Arena.Arena state value delta ->+  EquationId ->+  delta ->+  Equation value delta ->+  ST state Bool+evaluateEquationForInputM updateOutput domain arena input inputDelta equation =+  case evaluateDelta equation of+    Just derivative+      | not (deltaNull domain inputDelta) ->+          applyDeltaWithM updateOutput domain arena (equationOutput equation) (derivative input inputDelta)+    _ ->+      evaluateFullEquationChangedWithM updateOutput domain arena equation++evaluateFullEquationM :: DeltaDomain value delta -> Arena.Arena state value delta -> Equation value delta -> ST state ()+evaluateFullEquationM domain arena equation =+  void (evaluateFullEquationChangedM domain arena equation)++evaluateFullEquationChangedM :: DeltaDomain value delta -> Arena.Arena state value delta -> Equation value delta -> ST state Bool+evaluateFullEquationChangedM =+  evaluateFullEquationChangedWithM finiteOutputUpdate++evaluateFullEquationChangedWithM :: OutputUpdate value -> DeltaDomain value delta -> Arena.Arena state value delta -> Equation value delta -> ST state Bool+evaluateFullEquationChangedWithM updateOutput domain arena equation = do+  let outputKey = equationIdKey (equationOutput equation)+  oldValue <- MVector.read (Arena.values arena) outputKey+  newValue <- Arena.evaluate arena (evaluateFull equation)+  applyDeltaWithM updateOutput domain arena (equationOutput equation) (deltaBetween domain oldValue newValue)++applyDeltaWithM :: OutputUpdate value -> DeltaDomain value delta -> Arena.Arena state value delta -> EquationId -> delta -> ST state Bool+applyDeltaWithM updateOutput domain arena (EquationId key) deltaValue+  | deltaNull domain deltaValue = pure False+  | otherwise = do+      oldValue <- MVector.read (Arena.values arena) key+      let candidateValue =+            deltaApply domain deltaValue oldValue+          newValue =+            updateOutput key oldValue candidateValue+          effectiveDelta =+            deltaBetween domain oldValue newValue+      if deltaNull domain effectiveDelta+        then pure False+        else do+          MVector.write (Arena.values arena) key newValue+          Arena.mergePendingDelta domain arena key effectiveDelta+          pure True
+ src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Plan.hs view
@@ -0,0 +1,182 @@+-- | Solver plan construction from equations: id-range validation, dependency+-- SCC classification, snapshot/delta validation, and plan lookups. Pure.+module Moonlight.Core.Fixpoint.Internal.Solver.Plan+  ( planFromEquations,+    planWithConvergenceFromEquations,+    dense,+    validateSnapshot,+    validateDeltas,+    equationsForOutput,+    equationsUsingInput,+  )+where++import Data.Graph qualified as Graph+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import Moonlight.Core.Fixpoint.Internal.Solver.Types+  ( ConvergencePlan (..),+    DeltaDomain (..),+    Equation (..),+    EquationId (..),+    Evaluation,+    Component (..),+    Obstruction (..),+    Plan (..),+    Snapshot (..),+    equationIdKey,+    evaluationInputs,+  )+import Prelude++-- | Build a solver plan over a caller-declared number of value slots.+--+-- Every equation id (output and input) must lie in @[0, valueCount)@;+-- ids outside that range are rejected as obstructions. Dense solving+-- allocates an arena of exactly @valueCount@ slots, so plan memory is+-- the declared capacity, never an inferred maximum id.+planFromEquations :: Foldable container => Int -> container (Equation value delta) -> Either Obstruction (Plan value delta)+planFromEquations =+  planWithConvergenceFromEquations FiniteHeightScc++-- | 'planFromEquations' with an explicit convergence plan; the same+-- id-capacity contract applies.+planWithConvergenceFromEquations ::+  Foldable container =>+  ConvergencePlan value ->+  Int ->+  container (Equation value delta) ->+  Either Obstruction (Plan value delta)+planWithConvergenceFromEquations convergence valueCount equations =+  fromVector convergence valueCount (Vector.fromList (foldr (:) [] equations))++dense ::+  Int ->+  (Int -> Evaluation value value) ->+  Either Obstruction (Plan value delta)+dense valueCount evaluate =+  fromVector FiniteHeightScc count equations+  where+    count =+      max 0 valueCount+    equations =+      Vector.generate count denseEquation+    denseEquation key =+      Equation+        { equationOutput = EquationId key,+          evaluateFull = evaluate key,+          evaluateDelta = Nothing+        }++indexEquationsByOutput :: Vector (Equation value delta) -> IntMap [Equation value delta]+indexEquationsByOutput =+  Vector.foldr insertEquationByOutput IntMap.empty++insertEquationByOutput :: Equation value delta -> IntMap [Equation value delta] -> IntMap [Equation value delta]+insertEquationByOutput equation =+  IntMap.insertWith (<>) (equationIdKey (equationOutput equation)) [equation]++indexUsersByInput :: (Equation value delta -> IntSet) -> Vector (Equation value delta) -> IntMap [Equation value delta]+indexUsersByInput dependenciesOf =+  Vector.foldr (insertEquationByInput dependenciesOf) IntMap.empty++insertEquationByInput :: (Equation value delta -> IntSet) -> Equation value delta -> IntMap [Equation value delta] -> IntMap [Equation value delta]+insertEquationByInput dependenciesOf equation users =+  IntSet.foldr+    (\input -> IntMap.insertWith (<>) input [equation])+    users+    (dependenciesOf equation)++componentsFromEquations :: (Equation value delta -> IntSet) -> Vector (Equation value delta) -> [Component]+componentsFromEquations dependenciesOf equations =+  fmap fromScc $+    Graph.stronglyConnComp+      [ (EquationId output, output, IntSet.toAscList inputs)+        | (output, inputs) <- IntMap.toAscList outputDependencies+      ]+  where+    outputDependencies =+      Vector.foldr (insertEquationDependencies dependenciesOf) IntMap.empty equations+    fromScc (Graph.AcyclicSCC output) = AcyclicOutput output+    fromScc (Graph.CyclicSCC outputs) = CyclicOutputs (IntSet.fromList (fmap unEquationId outputs))++insertEquationDependencies :: (Equation value delta -> IntSet) -> Equation value delta -> IntMap IntSet -> IntMap IntSet+insertEquationDependencies dependenciesOf equation =+  IntMap.insertWith+    IntSet.union+    (equationIdKey (equationOutput equation))+    (dependenciesOf equation)++equationDependencies :: Equation value delta -> IntSet+equationDependencies =+  evaluationInputs . evaluateFull++fromVector :: ConvergencePlan value -> Int -> Vector (Equation value delta) -> Either Obstruction (Plan value delta)+fromVector convergence valueCount equationVector =+  case firstInvalidEquationId capacity equationVector of+    Just obstruction ->+      Left obstruction+    Nothing ->+      Right+        Plan+          { valueCount = capacity,+            convergencePlan = convergence,+            components = componentsFromEquations equationDependencies equationVector,+            equationsByOutput = indexEquationsByOutput equationVector,+            usersByInput = indexUsersByInput equationDependencies equationVector+          }+  where+    capacity =+      max 0 valueCount++firstInvalidEquationId :: Int -> Vector (Equation value delta) -> Maybe Obstruction+firstInvalidEquationId capacity =+  Vector.foldr firstInvalidInEquation Nothing+  where+    firstInvalidInEquation :: Equation value delta -> Maybe Obstruction -> Maybe Obstruction+    firstInvalidInEquation equation found =+      firstInvalidId (equationOutput equation) (firstInvalidInputs (equationDependencies equation) found)+    firstInvalidInputs :: IntSet -> Maybe Obstruction -> Maybe Obstruction+    firstInvalidInputs inputs found =+      IntSet.foldr (\key -> firstInvalidId (EquationId key)) found inputs+    firstInvalidId :: EquationId -> Maybe Obstruction -> Maybe Obstruction+    firstInvalidId equationId@(EquationId key) found+      | key < 0 = Just (NegativeEquationId equationId)+      | key >= capacity = Just (EquationIdExceedsCapacity equationId capacity)+      | otherwise = found++validateSnapshot :: Plan value delta -> Snapshot value delta -> Either Obstruction ()+validateSnapshot plan snapshot+  | snapshotSize /= valueCount plan =+      Left (SnapshotSizeMismatch (valueCount plan) snapshotSize)+  | otherwise =+      Right ()+  where+    snapshotSize =+      Vector.length (snapshotValues snapshot)++validateDeltas :: DeltaDomain value delta -> Plan value delta -> IntMap delta -> Either Obstruction ()+validateDeltas domain plan =+  foldr validateDelta (Right ()) . IntMap.toAscList+  where+    planCapacity =+      valueCount plan+    validateDelta (key, deltaValue) next+      | deltaNull domain deltaValue =+          next+      | key < 0 || key >= planCapacity =+          Left (DeltaOutOfBounds (EquationId key) planCapacity)+      | otherwise =+          next++equationsForOutput :: EquationId -> Plan value delta -> [Equation value delta]+equationsForOutput output plan =+  IntMap.findWithDefault [] (equationIdKey output) (equationsByOutput plan)++equationsUsingInput :: EquationId -> Plan value delta -> [Equation value delta]+equationsUsingInput input plan =+  IntMap.findWithDefault [] (equationIdKey input) (usersByInput plan)
+ src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Types.hs view
@@ -0,0 +1,118 @@+-- | Solver carrier types: equation ids, evaluation programs, delta domains, plans,+-- obstructions, snapshots, and results. Pure data; no mutation.+module Moonlight.Core.Fixpoint.Internal.Solver.Types+  ( EquationId (..),+    equationIdKey,+    Evaluation (..),+    EquationRead (..),+    readEquationValue,+    evaluationInputs,+    DeltaDomain (..),+    Equation (..),+    ConvergencePlan (..),+    WideningPolicy (..),+    Plan (..),+    Obstruction (..),+    Snapshot (..),+    Result (..),+    Component (..),+    OutputUpdate,+  )+where++import Control.Applicative.Free (Ap, liftAp, runAp_)+import Data.IntMap.Strict (IntMap)+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Vector (Vector)+import Prelude++newtype EquationId = EquationId {unEquationId :: Int}+  deriving stock (Eq, Ord, Show, Read)++equationIdKey :: EquationId -> Int+equationIdKey (EquationId key) =+  key++data EquationRead value result where+  ReadEquationValue :: !EquationId -> EquationRead value value++newtype Evaluation value result = Evaluation+  { evaluationProgram :: Ap (EquationRead value) result+  }++instance Functor (Evaluation value) where+  fmap project (Evaluation program) =+    Evaluation (fmap project program)++instance Applicative (Evaluation value) where+  pure =+    Evaluation . pure+  Evaluation function <*> Evaluation argument =+    Evaluation (function <*> argument)++readEquationValue :: EquationId -> Evaluation value value+readEquationValue =+  Evaluation . liftAp . ReadEquationValue++evaluationInputs :: Evaluation value result -> IntSet+evaluationInputs (Evaluation program) =+  runAp_ equationReadInput program++equationReadInput :: EquationRead value result -> IntSet+equationReadInput (ReadEquationValue equationId) =+  IntSet.singleton (equationIdKey equationId)++data DeltaDomain value delta = DeltaDomain+  { deltaEmpty :: !delta,+    deltaNull :: delta -> Bool,+    deltaMerge :: delta -> delta -> delta,+    deltaApply :: delta -> value -> value,+    deltaBetween :: value -> value -> delta+  }++data Equation value delta = Equation+  { equationOutput :: !EquationId,+    evaluateFull :: !(Evaluation value value),+    evaluateDelta :: !(Maybe (EquationId -> delta -> delta))+  }++data ConvergencePlan value+  = FiniteHeightScc+  | Widening !(WideningPolicy value)++data WideningPolicy value = WideningPolicy+  { wideningHeads :: !IntSet,+    widenAt :: !(Int -> value -> value -> value),+    narrowAt :: !(Int -> value -> value -> value)+  }++data Plan value delta = Plan+  { valueCount :: !Int,+    convergencePlan :: !(ConvergencePlan value),+    components :: ![Component],+    equationsByOutput :: !(IntMap [Equation value delta]),+    usersByInput :: !(IntMap [Equation value delta])+  }++data Obstruction+  = NegativeEquationId !EquationId+  | EquationIdExceedsCapacity !EquationId !Int+  | SnapshotSizeMismatch !Int !Int+  | DeltaOutOfBounds !EquationId !Int+  deriving stock (Eq, Show)++data Snapshot value delta = Snapshot+  { snapshotValues :: !(Vector value)+  }++data Result value delta = Result+  { resultValues :: !(Vector value),+    resultSnapshot :: !(Snapshot value delta)+  }++data Component+  = AcyclicOutput !EquationId+  | CyclicOutputs !IntSet++type OutputUpdate value = Int -> value -> value -> value
+ src-solver/Moonlight/Core/Fixpoint/Internal/Solver/WorkQueue.hs view
@@ -0,0 +1,74 @@+-- | A mutable ring-buffer work queue with membership dedup via a bit set.+module Moonlight.Core.Fixpoint.Internal.Solver.WorkQueue+  ( WorkQueue (..),+    new,+    enqueue,+    drain,+  )+where++import Control.Monad.ST (ST)+import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)+import Data.Vector.Unboxed.Mutable qualified as UMVector+import Moonlight.Core.Fixpoint.Internal.Solver.BitSet+  ( MutableBitSet,+    bitSetDelete,+    bitSetInsert,+    bitSetMember,+    newBitSet,+  )+import Prelude++data WorkQueue state = WorkQueue+  { items :: !(UMVector.MVector state Int),+    queued :: !(MutableBitSet state),+    headRef :: !(STRef state Int),+    sizeRef :: !(STRef state Int)+  }++new :: Int -> ST state (WorkQueue state)+new capacity = do+  items <- UMVector.replicate capacity 0+  queued <- newBitSet capacity+  headRef <- newSTRef 0+  sizeRef <- newSTRef 0+  pure+    WorkQueue+      { items = items,+        queued = queued,+        headRef = headRef,+        sizeRef = sizeRef+      }++enqueue :: WorkQueue state -> Int -> ST state ()+enqueue queue key = do+  alreadyQueued <- bitSetMember key (queued queue)+  if alreadyQueued+    then pure ()+    else do+      size <- readSTRef (sizeRef queue)+      headIndex <- readSTRef (headRef queue)+      let insertionIndex = (headIndex + size) `rem` UMVector.length (items queue)+      UMVector.write (items queue) insertionIndex key+      bitSetInsert key (queued queue)+      writeSTRef (sizeRef queue) (size + 1)++dequeue :: WorkQueue state -> ST state (Maybe Int)+dequeue queue = do+  size <- readSTRef (sizeRef queue)+  if size <= 0+    then pure Nothing+    else do+      headIndex <- readSTRef (headRef queue)+      key <- UMVector.read (items queue) headIndex+      bitSetDelete key (queued queue)+      writeSTRef (headRef queue) ((headIndex + 1) `rem` UMVector.length (items queue))+      writeSTRef (sizeRef queue) (size - 1)+      pure (Just key)++drain :: WorkQueue state -> (Int -> ST state ()) -> ST state ()+drain queue step = do+  item <- dequeue queue+  case item of+    Nothing -> pure ()+    Just key -> step key *> drain queue step
+ src-solver/Moonlight/Core/UnionFind.hs view
@@ -0,0 +1,225 @@+-- | A persistent union-find over e-graph class identifiers. The public value+-- remains immutable; batched mutation is available explicitly from+-- "Moonlight.Core.UnionFind.Transaction".+module Moonlight.Core.UnionFind+  ( UnionFind,+    UnionFindAllocationError (..),+    emptyUnionFind,+    fromClassIds,+    makeSet,+    insertClassId,+    member,+    find,+    findExisting,+    canonicalClass,+    union,+    equivalent,+    samePartition,+    canonicalMap,+    canonicalMapAndCompress,+  )+where++import Data.Foldable qualified as Foldable+import Data.IntMap.Strict+  ( IntMap,+  )+import Data.IntMap.Strict qualified as IntMap+import Moonlight.Core.Identifier.EGraph+  ( ClassId (..),+    classIdKey,+  )+import Moonlight.Core.UnionFind.Internal.Semantics+  ( LinkDecision (..),+    chooseLink,+  )+import Moonlight.Core.UnionFind.Internal.Types+  ( UnionFind (..),+    UnionFindAllocationError,+    advanceNextFreshForClassIdKey,+    allocateNextClassId,+  )+import Moonlight.Core.UnionFind.Transaction qualified as Transaction+import Prelude+  ( Bool,+    Eq ((==)),+    Foldable,+    Either,+    Int,+    Maybe (..),+    fmap,+    min,+    otherwise,+    pure,+    (.),+  )++emptyUnionFind :: UnionFind+emptyUnionFind =+  UnionFind+    { ufParent = IntMap.empty,+      ufRank = IntMap.empty,+      ufNextFresh = 0+    }++fromClassIds :: Foldable t => t ClassId -> UnionFind+fromClassIds =+  Foldable.foldl' (\unionFind classId -> insertClassId classId unionFind) emptyUnionFind++insertClassId :: ClassId -> UnionFind -> UnionFind+insertClassId classId unionFind =+  let key = classIdKey classId+   in if IntMap.member key (ufParent unionFind)+        then unionFind {ufNextFresh = advanceNextFreshForClassIdKey key (ufNextFresh unionFind)}+        else+          unionFind+            { ufParent = IntMap.insert key classId (ufParent unionFind),+              ufRank = IntMap.insert key 0 (ufRank unionFind),+              ufNextFresh = advanceNextFreshForClassIdKey key (ufNextFresh unionFind)+            }++member :: ClassId -> UnionFind -> Bool+member classId =+  IntMap.member (classIdKey classId) . ufParent++makeSet :: UnionFind -> Either UnionFindAllocationError (ClassId, UnionFind)+makeSet unionFind = do+  (classId, nextFresh) <- allocateNextClassId (ufNextFresh unionFind)+  let key = classIdKey classId+  pure+    ( classId,+      unionFind+        { ufParent = IntMap.insert key classId (ufParent unionFind),+          ufRank = IntMap.insert key 0 (ufRank unionFind),+          ufNextFresh = nextFresh+        }+    )++find :: ClassId -> UnionFind -> (ClassId, UnionFind)+find classId unionFind =+  let (rootKey, compressedParents) =+        compressRootKey (ufParent unionFind) (classIdKey classId)+   in ( ClassId rootKey,+        unionFind {ufParent = compressedParents}+      )++findExisting :: ClassId -> UnionFind -> Maybe (ClassId, UnionFind)+findExisting classId unionFind =+  if member classId unionFind+    then Just (find classId unionFind)+    else Nothing++canonicalClass :: ClassId -> UnionFind -> Maybe ClassId+canonicalClass classId unionFind =+  if member classId unionFind+    then Just (ClassId (rootKeyOf unionFind (classIdKey classId)))+    else Nothing++union :: ClassId -> ClassId -> UnionFind -> UnionFind+union leftClassId rightClassId unionFind =+  let seededUnionFind = insertClassId rightClassId (insertClassId leftClassId unionFind)+      (leftRoot, unionFindAfterLeft) = find leftClassId seededUnionFind+      (rightRoot, unionFindAfterRight) = find rightClassId unionFindAfterLeft+   in if leftRoot == rightRoot+        then unionFindAfterRight+        else linkRoots leftRoot rightRoot unionFindAfterRight++equivalent :: ClassId -> ClassId -> UnionFind -> Bool+equivalent leftClassId rightClassId unionFind =+  rootKeyOf unionFind (classIdKey leftClassId)+    == rootKeyOf unionFind (classIdKey rightClassId)++canonicalMap :: UnionFind -> IntMap ClassId+canonicalMap unionFind =+  IntMap.mapWithKey+    (\key _ -> ClassId (rootKeyOf unionFind key))+    (ufParent unionFind)++samePartition :: UnionFind -> UnionFind -> Bool+samePartition leftUnionFind rightUnionFind =+  partitionProjection leftUnionFind == partitionProjection rightUnionFind++partitionProjection :: UnionFind -> IntMap ClassId+partitionProjection unionFind =+  IntMap.map canonicalRootClass canonicalParents+  where+    canonicalParents =+      canonicalMap unionFind+    classMinima =+      IntMap.foldlWithKey' insertMinimum IntMap.empty canonicalParents+    insertMinimum minima memberKey rootClass =+      IntMap.insertWith min (classIdKey rootClass) (ClassId memberKey) minima+    canonicalRootClass rootClass =+      IntMap.findWithDefault rootClass (classIdKey rootClass) classMinima++canonicalMapAndCompress :: UnionFind -> (IntMap ClassId, UnionFind)+canonicalMapAndCompress unionFind =+  Transaction.runUnionFindTransaction unionFind Transaction.transactionCanonicalMapAndCompress++parentKeyOf :: UnionFind -> Int -> Maybe Int+parentKeyOf unionFind key =+  fmap classIdKey (IntMap.lookup key (ufParent unionFind))++rankOf :: ClassId -> UnionFind -> Int+rankOf classId unionFind =+  IntMap.findWithDefault 0 (classIdKey classId) (ufRank unionFind)++rootKeyOf :: UnionFind -> Int -> Int+rootKeyOf unionFind key =+  case parentKeyOf unionFind key of+    Nothing ->+      key+    Just parentKey+      | parentKey == key ->+          key+      | otherwise ->+          rootKeyOf unionFind parentKey++compressRootKey :: IntMap ClassId -> Int -> (Int, IntMap ClassId)+compressRootKey parents key =+  case IntMap.lookup key parents of+    Nothing ->+      (key, parents)+    Just parentClassId ->+      let parentKey = classIdKey parentClassId+       in if parentKey == key+            then (key, parents)+            else+              let (rootKey, compressedParents) =+                    compressRootKey parents parentKey+               in (rootKey, IntMap.insert key (ClassId rootKey) compressedParents)++linkRoots :: ClassId -> ClassId -> UnionFind -> UnionFind+linkRoots leftRoot rightRoot unionFind =+  applyLinkDecision+    ( chooseLink+        leftRoot+        (rankOf leftRoot unionFind)+        rightRoot+        (rankOf rightRoot unionFind)+    )+    unionFind++applyLinkDecision :: LinkDecision -> UnionFind -> UnionFind+applyLinkDecision decision unionFind =+  case decision of+    AttachRoot childRoot parentRoot ->+      setParent childRoot parentRoot unionFind+    AttachRootAndRaise childRoot parentRoot raisedRank ->+      (setParent childRoot parentRoot unionFind)+        { ufRank =+            IntMap.insert+              (classIdKey parentRoot)+              raisedRank+              (ufRank unionFind)+        }++setParent :: ClassId -> ClassId -> UnionFind -> UnionFind+setParent childClassId parentClassId unionFind =+  unionFind+    { ufParent =+        IntMap.insert+          (classIdKey childClassId)+          parentClassId+          (ufParent unionFind)+    }
+ src-solver/Moonlight/Core/UnionFind/Internal/Semantics.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE StandaloneKindSignatures #-}++module Moonlight.Core.UnionFind.Internal.Semantics+  ( LinkDecision (..),+    chooseLink,+    rootKeyBy,+  )+where++import Data.Kind+  ( Type,+  )+import Moonlight.Core.Identifier.EGraph+  ( ClassId,+  )+import Prelude+  ( Eq ((==)),+    Int,+    Maybe (..),+    Monad,+    Ord (compare, max, min),+    Ordering (..),+    Show,+    otherwise,+    (+),+    pure,+    (>>=),+  )++type LinkDecision :: Type+data LinkDecision+  = AttachRoot !ClassId !ClassId+  | AttachRootAndRaise !ClassId !ClassId !Int+  deriving stock (Eq, Show)++-- | Decide how two distinct roots are linked. Equal-rank links deterministically+-- retain the lesser 'ClassId'.+chooseLink :: ClassId -> Int -> ClassId -> Int -> LinkDecision+chooseLink leftRoot leftRank rightRoot rightRank =+  case compare leftRank rightRank of+    LT ->+      AttachRoot leftRoot rightRoot+    GT ->+      AttachRoot rightRoot leftRoot+    EQ ->+      AttachRootAndRaise+        (max leftRoot rightRoot)+        (min leftRoot rightRoot)+        (leftRank + 1)+{-# INLINE chooseLink #-}++-- | Shared forest ascent law for both persistent and transient storage.+-- A missing parent is a singleton root, and a self-parent terminates the path.+rootKeyBy ::+  Monad m =>+  (Int -> m (Maybe Int)) ->+  Int ->+  m Int+rootKeyBy readParentKey startKey =+  readParentKey startKey >>= \maybeParentKey ->+    case maybeParentKey of+      Nothing ->+        pure startKey+      Just parentKey+        | parentKey == startKey ->+            pure startKey+        | otherwise ->+            rootKeyBy readParentKey parentKey+{-# INLINE rootKeyBy #-}
+ src-solver/Moonlight/Core/UnionFind/Internal/Types.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE StandaloneKindSignatures #-}++module Moonlight.Core.UnionFind.Internal.Types+  ( UnionFind (..),+    UnionFindAllocationError (..),+    advanceNextFreshForClassIdKey,+    allocateNextClassId,+  )+where++import Control.DeepSeq (NFData (rnf))+import Data.IntMap.Strict+  ( IntMap,+  )+import Data.Kind+  ( Type,+  )+import Moonlight.Core.Identifier.EGraph+  ( ClassId (..),+  )+import Prelude+  ( Either (..),+    Eq,+    Int,+    Integer,+    Ord,+    Read,+    Show,+    fromInteger,+    max,+    maxBound,+    otherwise,+    toInteger,+    (+),+    (<),+    (>),+  )++type UnionFind :: Type+data UnionFind = UnionFind+  { ufParent :: !(IntMap ClassId),+    ufRank :: !(IntMap Int),+    ufNextFresh :: !Integer+  }+  deriving stock (Show)++type UnionFindAllocationError :: Type+data UnionFindAllocationError+  = ClassIdSpaceExhausted+  deriving stock (Eq, Ord, Show, Read)++instance NFData UnionFindAllocationError where+  rnf ClassIdSpaceExhausted = ()++advanceNextFreshForClassIdKey :: Int -> Integer -> Integer+advanceNextFreshForClassIdKey key current+  | key < 0 = current+  | otherwise = max current (toInteger key + 1)++allocateNextClassId :: Integer -> Either UnionFindAllocationError (ClassId, Integer)+allocateNextClassId nextFresh+  | nextFresh > toInteger (maxBound :: Int) = Left ClassIdSpaceExhausted+  | otherwise = Right (ClassId (fromInteger nextFresh), nextFresh + 1)
+ src-solver/Moonlight/Core/UnionFind/Transaction.hs view
@@ -0,0 +1,179 @@+-- | A sealed mutable execution mode for the canonical persistent union-find.+-- Dense non-negative prefixes use mutable parent/rank arrays with in-place path+-- compression; sparse, negative, and giant keys stay in an 'IntMap' overlay.+-- Successful transactions freeze back to the immutable 'UnionFind' owner.+--+-- This module is the public face: the two transaction runners (the only+-- @runST@ seals) and the query/mutation verbs. The mutable arena lives in+-- sealed @Transaction.Internal.*@ owners; 'UnionFindEditor' is re-exported+-- abstractly so no external caller can forge or dissect editor state.+module Moonlight.Core.UnionFind.Transaction+  ( UnionFindEditor,+    UnionOutcome (..),+    UnionFindAllocationError (..),+    runUnionFindTransaction,+    runUnionFindTransactionEither,+    transactionMember,+    transactionFind,+    transactionFindExisting,+    transactionCanonicalClass,+    transactionInsertClassId,+    transactionMakeSet,+    transactionUnion,+    transactionEquivalent,+    transactionCanonicalMapAndCompress,+  )+where++import Control.Monad.ST (ST, runST)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Maybe (isJust)+import Data.STRef (modifySTRef', readSTRef, writeSTRef)+import Moonlight.Core.Identifier.EGraph (ClassId (..), classIdKey)+import Moonlight.Core.UnionFind.Internal.Semantics (chooseLink, rootKeyBy)+import Moonlight.Core.UnionFind.Internal.Types+  ( UnionFind,+    UnionFindAllocationError (..),+    advanceNextFreshForClassIdKey,+    allocateNextClassId,+  )+import Moonlight.Core.UnionFind.Transaction.Internal.Algorithm+  ( applyLinkDecision,+    compressRootKey,+  )+import Moonlight.Core.UnionFind.Transaction.Internal.Lifecycle+  ( freezeUnionFind,+    thawUnionFind,+  )+import Moonlight.Core.UnionFind.Transaction.Internal.Snapshot+  ( parentMap,+  )+import Moonlight.Core.UnionFind.Transaction.Internal.Storage+  ( readParentKey,+    readRankValue,+    writeFreshClassIdentity,+  )+import Moonlight.Core.UnionFind.Transaction.Internal.Types+  ( UnionFindEditor (nextFresh),+    UnionOutcome (..),+  )+import Prelude++runUnionFindTransaction ::+  UnionFind ->+  (forall state. UnionFindEditor state -> ST state value) ->+  (value, UnionFind)+runUnionFindTransaction base action =+  runST $ do+    editor <- thawUnionFind base+    value <- action editor+    committed <- freezeUnionFind editor+    pure (value, committed)++runUnionFindTransactionEither ::+  UnionFind ->+  (forall state. UnionFindEditor state -> ST state (Either err value)) ->+  Either err (value, UnionFind)+runUnionFindTransactionEither base action =+  runST $ do+    editor <- thawUnionFind base+    outcome <- action editor+    case outcome of+      Left err ->+        pure (Left err)+      Right value -> do+        committed <- freezeUnionFind editor+        pure (Right (value, committed))++transactionMember :: UnionFindEditor state -> ClassId -> ST state Bool+transactionMember editor classId =+  fmap isJust (readParentKey editor (classIdKey classId))+{-# INLINE transactionMember #-}++transactionFind :: UnionFindEditor state -> ClassId -> ST state ClassId+transactionFind editor classId =+  fmap ClassId (compressRootKey editor (classIdKey classId))+{-# INLINE transactionFind #-}++transactionFindExisting ::+  UnionFindEditor state ->+  ClassId ->+  ST state (Maybe ClassId)+transactionFindExisting editor classId = do+  exists <- transactionMember editor classId+  if exists+    then fmap Just (transactionFind editor classId)+    else pure Nothing+{-# INLINE transactionFindExisting #-}++transactionCanonicalClass ::+  UnionFindEditor state ->+  ClassId ->+  ST state (Maybe ClassId)+transactionCanonicalClass editor classId = do+  exists <- transactionMember editor classId+  if exists+    then fmap (Just . ClassId) (rootKeyBy (readParentKey editor) (classIdKey classId))+    else pure Nothing+{-# INLINE transactionCanonicalClass #-}++transactionInsertClassId :: UnionFindEditor state -> ClassId -> ST state ()+transactionInsertClassId editor classId = do+  let key = classIdKey classId+  modifySTRef' (nextFresh editor) (advanceNextFreshForClassIdKey key)+  exists <- fmap isJust (readParentKey editor key)+  if exists+    then pure ()+    else writeFreshClassIdentity editor key+{-# INLINE transactionInsertClassId #-}++transactionMakeSet :: UnionFindEditor state -> ST state (Either UnionFindAllocationError ClassId)+transactionMakeSet editor = do+  currentNextFresh <- readSTRef (nextFresh editor)+  case allocateNextClassId currentNextFresh of+    Left allocationError ->+      pure (Left allocationError)+    Right (classId, updatedNextFresh) -> do+      writeFreshClassIdentity editor (classIdKey classId)+      writeSTRef (nextFresh editor) updatedNextFresh+      pure (Right classId)+{-# INLINE transactionMakeSet #-}++transactionUnion ::+  UnionFindEditor state ->+  ClassId ->+  ClassId ->+  ST state UnionOutcome+transactionUnion editor leftClassId rightClassId = do+  transactionInsertClassId editor leftClassId+  transactionInsertClassId editor rightClassId+  leftRoot <- transactionFind editor leftClassId+  rightRoot <- transactionFind editor rightClassId+  if leftRoot == rightRoot+    then pure (AlreadyEquivalent leftRoot)+    else do+      leftRank <- readRankValue editor (classIdKey leftRoot)+      rightRank <- readRankValue editor (classIdKey rightRoot)+      applyLinkDecision editor (chooseLink leftRoot leftRank rightRoot rightRank)+{-# INLINE transactionUnion #-}++transactionEquivalent ::+  UnionFindEditor state ->+  ClassId ->+  ClassId ->+  ST state Bool+transactionEquivalent editor leftClassId rightClassId = do+  leftRoot <- rootKeyBy (readParentKey editor) (classIdKey leftClassId)+  rightRoot <- rootKeyBy (readParentKey editor) (classIdKey rightClassId)+  pure (leftRoot == rightRoot)+{-# INLINE transactionEquivalent #-}++transactionCanonicalMapAndCompress ::+  UnionFindEditor state ->+  ST state (IntMap ClassId)+transactionCanonicalMapAndCompress editor = do+  currentParents <- parentMap editor+  IntMap.traverseWithKey+    (\key _ -> transactionFind editor (ClassId key))+    currentParents
+ src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Algorithm.hs view
@@ -0,0 +1,56 @@+-- | The two union-find algorithms in mutable form: iterated path compression to+-- a root, and application of a rank-directed link decision.+module Moonlight.Core.UnionFind.Transaction.Internal.Algorithm+  ( compressRootKey,+    applyLinkDecision,+  )+where++import Control.Monad.ST (ST)+import Data.Foldable (traverse_)+import Moonlight.Core.Identifier.EGraph (classIdKey)+import Moonlight.Core.UnionFind.Internal.Semantics+  ( LinkDecision (..),+  )+import Moonlight.Core.UnionFind.Transaction.Internal.Storage+  ( readParentKey,+    writeParentKey,+    writeRankValue,+  )+import Moonlight.Core.UnionFind.Transaction.Internal.Types+  ( UnionFindEditor,+    UnionOutcome (..),+  )+import Prelude++compressRootKey :: UnionFindEditor state -> Int -> ST state Int+compressRootKey editor key = do+  maybeParentKey <- readParentKey editor key+  case maybeParentKey of+    Nothing ->+      pure key+    Just parentKey+      | parentKey == key ->+          pure key+      | otherwise -> do+          rootKey <- compressRootKey editor parentKey+          writeParentKey editor key rootKey+          pure rootKey+{-# INLINE compressRootKey #-}++applyLinkDecision ::+  UnionFindEditor state ->+  LinkDecision ->+  ST state UnionOutcome+applyLinkDecision editor decision = do+  let (childRoot, parentRoot, maybeRaisedRank) =+        case decision of+          AttachRoot child parent ->+            (child, parent, Nothing)+          AttachRootAndRaise child parent raisedRank ->+            (child, parent, Just raisedRank)+  writeParentKey editor (classIdKey childRoot) (classIdKey parentRoot)+  traverse_+    (\raisedRank -> writeRankValue editor (classIdKey parentRoot) raisedRank)+    maybeRaisedRank+  pure (MergedClasses parentRoot childRoot)
+ src-solver/Moonlight/Core/UnionFind/Transaction/Internal/DenseStore.hs view
@@ -0,0 +1,215 @@+-- | Raw dense-arena primitives: presence-gated parent/rank reads and writes,+-- slot initialization, dirty-key tracking, and capacity growth. All mutation+-- is confined here behind the presence flag.+module Moonlight.Core.UnionFind.Transaction.Internal.DenseStore+  ( readDenseParentKey,+    readDenseRank,+    denseSlotPresent,+    writeDenseParentIfPresent,+    writeDenseRankIfPresent,+    initializeDenseSlot,+    ensureDenseCapacity,+    growDenseStore,+    growZeroed,+  )+where++import Control.Monad.ST (ST)+import Data.STRef (modifySTRef', readSTRef, writeSTRef)+import Data.Vector.Unboxed (Unbox)+import Data.Vector.Unboxed.Mutable (MVector)+import Data.Vector.Unboxed.Mutable qualified as Mutable+import Moonlight.Core.UnionFind.Transaction.Internal.Policy+  ( denseKeyInBounds,+    denseTargetLength,+  )+import Moonlight.Core.UnionFind.Transaction.Internal.Types+  ( DenseStore (..),+    UnionFindEditor (..),+    denseFlagSet,+  )+import Prelude++readDenseParentKey ::+  UnionFindEditor state ->+  Int ->+  ST state (Maybe Int)+readDenseParentKey editor key = do+  store <- readSTRef (dense editor)+  if denseKeyInBounds store key+    then do+      present <- Mutable.read (present store) key+      if present == denseFlagSet+        then fmap Just (Mutable.read (parent store) key)+        else pure Nothing+    else pure Nothing+{-# INLINE readDenseParentKey #-}++readDenseRank ::+  UnionFindEditor state ->+  Int ->+  ST state (Maybe Int)+readDenseRank editor key = do+  store <- readSTRef (dense editor)+  if denseKeyInBounds store key+    then do+      present <- Mutable.read (present store) key+      if present == denseFlagSet+        then fmap Just (Mutable.read (rank store) key)+        else pure Nothing+    else pure Nothing+{-# INLINE readDenseRank #-}++denseSlotPresent ::+  UnionFindEditor state ->+  Int ->+  ST state Bool+denseSlotPresent editor key = do+  store <- readSTRef (dense editor)+  if denseKeyInBounds store key+    then fmap (== denseFlagSet) (Mutable.read (present store) key)+    else pure False+{-# INLINE denseSlotPresent #-}++writeDenseParentIfPresent ::+  UnionFindEditor state ->+  Int ->+  Int ->+  ST state Bool+writeDenseParentIfPresent editor key parentKey = do+  store <- readSTRef (dense editor)+  if denseKeyInBounds store key+    then do+      present <- Mutable.read (present store) key+      if present == denseFlagSet+        then do+          Mutable.write (parent store) key parentKey+          markDenseParentDirty editor store key+          pure True+        else pure False+    else pure False+{-# INLINE writeDenseParentIfPresent #-}++writeDenseRankIfPresent ::+  UnionFindEditor state ->+  Int ->+  Int ->+  ST state Bool+writeDenseRankIfPresent editor key rankValue = do+  store <- readSTRef (dense editor)+  if denseKeyInBounds store key+    then do+      present <- Mutable.read (present store) key+      if present == denseFlagSet+        then do+          Mutable.write (rank store) key rankValue+          markDenseRankDirty editor store key+          pure True+        else pure False+    else pure False+{-# INLINE writeDenseRankIfPresent #-}++initializeDenseSlot ::+  UnionFindEditor state ->+  Int ->+  ST state Bool+initializeDenseSlot editor key = do+  store <- readSTRef (dense editor)+  if denseKeyInBounds store key+    then do+      Mutable.write (parent store) key key+      Mutable.write (rank store) key 0+      Mutable.write (present store) key denseFlagSet+      markDenseParentDirty editor store key+      markDenseRankDirty editor store key+      modifySTRef' (denseMemberCount editor) (+ 1)+      pure True+    else pure False++markDenseParentDirty ::+  UnionFindEditor state ->+  DenseStore state ->+  Int ->+  ST state ()+markDenseParentDirty editor store key = do+  dirty <- Mutable.read (parentDirty store) key+  if dirty == denseFlagSet+    then pure ()+    else do+      Mutable.write (parentDirty store) key denseFlagSet+      modifySTRef' (dirtyDenseParents editor) (key :)+      modifySTRef' (dirtyDenseParentCount editor) (+ 1)+{-# INLINE markDenseParentDirty #-}++markDenseRankDirty ::+  UnionFindEditor state ->+  DenseStore state ->+  Int ->+  ST state ()+markDenseRankDirty editor store key = do+  dirty <- Mutable.read (rankDirty store) key+  if dirty == denseFlagSet+    then pure ()+    else do+      Mutable.write (rankDirty store) key denseFlagSet+      modifySTRef' (dirtyDenseRanks editor) (key :)+      modifySTRef' (dirtyDenseRankCount editor) (+ 1)+{-# INLINE markDenseRankDirty #-}++ensureDenseCapacity ::+  UnionFindEditor state ->+  Int ->+  ST state Bool+ensureDenseCapacity editor key = do+  store <- readSTRef (dense editor)+  let currentLength = Mutable.length (parent store)+  case denseTargetLength currentLength key of+    Nothing ->+      pure False+    Just targetLength+      | targetLength <= currentLength ->+          pure True+      | currentLength == 0 ->+          growDenseStore editor store targetLength+      | otherwise -> do+          denseMemberCount <- readSTRef (denseMemberCount editor)+          if denseMemberCount * 4 >= currentLength * 3+            then growDenseStore editor store targetLength+            else pure False++growDenseStore ::+  UnionFindEditor state ->+  DenseStore state ->+  Int ->+  ST state Bool+growDenseStore editor store targetLength = do+  parents <- growZeroed (parent store) targetLength+  ranks <- growZeroed (rank store) targetLength+  presence <- growZeroed (present store) targetLength+  dirtyParents <- growZeroed (parentDirty store) targetLength+  dirtyRanks <- growZeroed (rankDirty store) targetLength+  writeSTRef+    (dense editor)+    DenseStore+      { parent = parents,+        rank = ranks,+        present = presence,+        parentDirty = dirtyParents,+        rankDirty = dirtyRanks+      }+  pure True++growZeroed ::+  (Unbox value, Num value) =>+  MVector state value ->+  Int ->+  ST state (MVector state value)+growZeroed values targetLength =+  let currentLength = Mutable.length values+      additionalLength = targetLength - currentLength+   in if additionalLength <= 0+        then pure values+        else do+          grownValues <- Mutable.grow values additionalLength+          Mutable.set (Mutable.slice currentLength additionalLength grownValues) 0+          pure grownValues
+ src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Lifecycle.hs view
@@ -0,0 +1,112 @@+-- | The commit/abort boundary: thawing an immutable 'UnionFind' into a mutable+-- editor, materializing its dense prefix, and freezing a mutated editor back to+-- an immutable owner (returning the base unchanged when nothing was written).+module Moonlight.Core.UnionFind.Transaction.Internal.Lifecycle+  ( thawUnionFind,+    freezeUnionFind,+    materializeDenseBase,+  )+where++import Control.Monad.ST (ST)+import Data.Foldable (traverse_)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.STRef (newSTRef, readSTRef)+import Data.Vector.Unboxed.Mutable qualified as Mutable+import Moonlight.Core.Identifier.EGraph (ClassId (..))+import Moonlight.Core.UnionFind.Internal.Types (UnionFind (..))+import Moonlight.Core.UnionFind.Transaction.Internal.Policy+  ( chooseDenseLength,+    densePrefixMap,+  )+import Moonlight.Core.UnionFind.Transaction.Internal.Snapshot+  ( parentMap,+    rankMap,+  )+import Moonlight.Core.UnionFind.Transaction.Internal.Types+  ( DenseStore (..),+    UnionFindEditor (..),+    denseFlagSet,+    denseFlagUnset,+  )+import Prelude++thawUnionFind :: UnionFind -> ST state (UnionFindEditor state)+thawUnionFind base = do+  let denseLength = chooseDenseLength (ufParent base)+      denseBaseParents = densePrefixMap denseLength (ufParent base)+  denseParents <- Mutable.replicate denseLength 0+  denseRanks <- Mutable.replicate denseLength 0+  densePresence <- Mutable.replicate denseLength denseFlagUnset+  dirtyParents <- Mutable.replicate denseLength denseFlagUnset+  dirtyRanks <- Mutable.replicate denseLength denseFlagUnset+  denseReference <-+    newSTRef+      DenseStore+        { parent = denseParents,+          rank = denseRanks,+          present = densePresence,+          parentDirty = dirtyParents,+          rankDirty = dirtyRanks+        }+  sparseParentWrites <- newSTRef IntMap.empty+  sparseRankWrites <- newSTRef IntMap.empty+  dirtyDenseParents <- newSTRef []+  dirtyDenseRanks <- newSTRef []+  dirtyDenseParentCount <- newSTRef 0+  dirtyDenseRankCount <- newSTRef 0+  denseMemberCount <- newSTRef (IntMap.size denseBaseParents)+  nextFresh <- newSTRef (ufNextFresh base)+  let editor =+        UnionFindEditor+          { base = base,+            dense = denseReference,+            sparseParentWrites = sparseParentWrites,+            sparseRankWrites = sparseRankWrites,+            dirtyDenseParents = dirtyDenseParents,+            dirtyDenseRanks = dirtyDenseRanks,+            dirtyDenseParentCount = dirtyDenseParentCount,+            dirtyDenseRankCount = dirtyDenseRankCount,+            denseMemberCount = denseMemberCount,+            nextFresh = nextFresh+          }+  materializeDenseBase editor denseBaseParents+  pure editor++freezeUnionFind :: UnionFindEditor state -> ST state UnionFind+freezeUnionFind editor = do+  sparseParentWrites <- readSTRef (sparseParentWrites editor)+  sparseRankWrites <- readSTRef (sparseRankWrites editor)+  dirtyDenseParents <- readSTRef (dirtyDenseParents editor)+  dirtyDenseRanks <- readSTRef (dirtyDenseRanks editor)+  nextFresh <- readSTRef (nextFresh editor)+  if IntMap.null sparseParentWrites+    && IntMap.null sparseRankWrites+    && null dirtyDenseParents+    && null dirtyDenseRanks+    && nextFresh == ufNextFresh (base editor)+    then pure (base editor)+    else do+      parents <- parentMap editor+      ranks <- rankMap editor+      pure+        UnionFind+          { ufParent = parents,+            ufRank = ranks,+            ufNextFresh = nextFresh+          }++materializeDenseBase ::+  UnionFindEditor state ->+  IntMap ClassId ->+  ST state ()+materializeDenseBase editor denseParents = do+  store <- readSTRef (dense editor)+  traverse_+    (\(key, ClassId parentKey) -> do+       Mutable.write (parent store) key parentKey+       Mutable.write (rank store) key (IntMap.findWithDefault 0 key (ufRank (base editor)))+       Mutable.write (present store) key denseFlagSet+    )+    (IntMap.toAscList denseParents)
+ src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Policy.hs view
@@ -0,0 +1,106 @@+-- | Pure dense-prefix sizing policy: how many dense slots to allocate for a+-- given key distribution, growth targets, and the in-bounds predicate. No 'ST'.+module Moonlight.Core.UnionFind.Transaction.Internal.Policy+  ( chooseDenseLength,+    selectDenseLength,+    countKeysBelow,+    densePrefixMap,+    denseTargetLength,+    denseKeyInBounds,+  )+where++import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Vector.Unboxed.Mutable qualified as Mutable+import Moonlight.Core.Identifier.EGraph (ClassId)+import Moonlight.Core.UnionFind.Transaction.Internal.Types+  ( DenseStore (..),+    maximumDenseSlots,+    minimumDenseSlots,+  )+import Prelude++chooseDenseLength :: IntMap ClassId -> Int+chooseDenseLength parents+  | IntMap.null parents =+      minimumDenseSlots+  | otherwise =+      selectDenseLength+        (IntMap.keys (densePrefixMap maximumDenseSlots parents))+        denseCandidates+        0+        0+  where+    denseCandidates =+      takeWhile+        (<= maximumDenseSlots)+        (iterate (* 2) minimumDenseSlots)++selectDenseLength ::+  [Int] ->+  [Int] ->+  Int ->+  Int ->+  Int+selectDenseLength remainingKeys remainingLimits observedCount bestLength =+  case remainingLimits of+    [] ->+      bestLength+    limit : trailingLimits ->+      let (countAtLimit, keysAtOrAboveLimit) =+            countKeysBelow limit observedCount remainingKeys+          accepted =+            countAtLimit > 0+              && ( limit == minimumDenseSlots+                     || countAtLimit * 4 >= limit * 3+                 )+          nextBest =+            if accepted+              then limit+              else bestLength+       in selectDenseLength keysAtOrAboveLimit trailingLimits countAtLimit nextBest++countKeysBelow :: Int -> Int -> [Int] -> (Int, [Int])+countKeysBelow limit =+  go+  where+    go count keys =+      case keys of+        key : trailingKeys+          | key < limit ->+              go (count + 1) trailingKeys+        _ ->+          (count, keys)++densePrefixMap :: Int -> IntMap value -> IntMap value+densePrefixMap limit entries+  | limit <= 0 =+      IntMap.empty+  | otherwise =+      let (_, nonNegativeEntries) = IntMap.split (-1) entries+          (prefixEntries, _) = IntMap.split limit nonNegativeEntries+       in prefixEntries++denseTargetLength :: Int -> Int -> Maybe Int+denseTargetLength currentLength key+  | key < 0 =+      Nothing+  | key >= maximumDenseSlots =+      Nothing+  | key < currentLength =+      Just currentLength+  | currentLength == 0 =+      if key < minimumDenseSlots+        then Just minimumDenseSlots+        else Nothing+  | key < min maximumDenseSlots (currentLength * 2) =+      Just (min maximumDenseSlots (currentLength * 2))+  | otherwise =+      Nothing++denseKeyInBounds :: DenseStore state -> Int -> Bool+denseKeyInBounds store key =+  key >= 0+    && key < Mutable.length (parent store)+{-# INLINE denseKeyInBounds #-}
+ src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Snapshot.hs view
@@ -0,0 +1,157 @@+-- | Freezing the editor back to immutable maps: parent/rank snapshots that+-- choose between a full dense sweep and a dirty-key overlay depending on which+-- is cheaper, with the dense sweeps producing ascending entry lists.+module Moonlight.Core.UnionFind.Transaction.Internal.Snapshot+  ( parentMap,+    rankMap,+  )+where++import Control.Monad.ST (ST)+import Data.Foldable (foldlM)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.STRef (STRef, readSTRef)+import Data.Vector.Unboxed.Mutable qualified as Mutable+import Moonlight.Core.Identifier.EGraph (ClassId (..))+import Moonlight.Core.UnionFind.Internal.Types (UnionFind (..))+import Moonlight.Core.UnionFind.Transaction.Internal.DenseStore+  ( readDenseParentKey,+    readDenseRank,+  )+import Moonlight.Core.UnionFind.Transaction.Internal.Types+  ( DenseStore (..),+    UnionFindEditor (..),+    denseFlagSet,+  )+import Prelude++parentMap ::+  UnionFindEditor state ->+  ST state (IntMap ClassId)+parentMap editor = do+  sparseWrites <- readSTRef (sparseParentWrites editor)+  useDenseSnapshot <- denseOutweighsDirtyOverlay editor (dirtyDenseParentCount editor)+  if IntMap.null (ufParent (base editor)) || useDenseSnapshot+    then do+      denseParents <- denseParentMap editor+      pure (IntMap.union denseParents (IntMap.union sparseWrites (ufParent (base editor))))+    else do+      dirtyDenseKeys <- readSTRef (dirtyDenseParents editor)+      foldlM+        insertDenseParent+        (IntMap.union sparseWrites (ufParent (base editor)))+        dirtyDenseKeys+  where+    insertDenseParent parents key = do+      maybeParentKey <- readDenseParentKey editor key+      pure $+        case maybeParentKey of+          Nothing ->+            parents+          Just parentKey ->+            IntMap.insert key (ClassId parentKey) parents++denseOutweighsDirtyOverlay ::+  UnionFindEditor state ->+  STRef state Int ->+  ST state Bool+denseOutweighsDirtyOverlay editor dirtyCountReference = do+  dirtyCount <- readSTRef dirtyCountReference+  denseMemberCount <- readSTRef (denseMemberCount editor)+  pure (dirtyCount * 4 >= denseMemberCount)++denseParentMap ::+  UnionFindEditor state ->+  ST state (IntMap ClassId)+denseParentMap editor = do+  store <- readSTRef (dense editor)+  entries <-+    denseParentEntries+      store+      0+      (Mutable.length (parent store))+      []+  pure (IntMap.fromDistinctAscList entries)++denseParentEntries ::+  DenseStore state ->+  Int ->+  Int ->+  [(Int, ClassId)] ->+  ST state [(Int, ClassId)]+denseParentEntries store key limit entries+  | key >= limit =+      pure (reverse entries)+  | otherwise = do+      present <- Mutable.read (present store) key+      if present == denseFlagSet+        then do+          parentKey <- Mutable.read (parent store) key+          denseParentEntries+            store+            (key + 1)+            limit+            ((key, ClassId parentKey) : entries)+        else denseParentEntries store (key + 1) limit entries++rankMap ::+  UnionFindEditor state ->+  ST state (IntMap Int)+rankMap editor = do+  sparseWrites <- readSTRef (sparseRankWrites editor)+  useDenseSnapshot <- denseOutweighsDirtyOverlay editor (dirtyDenseRankCount editor)+  if IntMap.null (ufRank (base editor)) || useDenseSnapshot+    then do+      denseRanks <- denseRankMap editor+      pure+        (IntMap.union denseRanks (IntMap.union sparseWrites (ufRank (base editor))))+    else do+      dirtyDenseKeys <- readSTRef (dirtyDenseRanks editor)+      foldlM+        insertDenseRank+        (IntMap.union sparseWrites (ufRank (base editor)))+        dirtyDenseKeys+  where+    insertDenseRank ranks key = do+      maybeRank <- readDenseRank editor key+      pure $+        case maybeRank of+          Nothing ->+            ranks+          Just rankValue ->+            IntMap.insert key rankValue ranks++denseRankMap ::+  UnionFindEditor state ->+  ST state (IntMap Int)+denseRankMap editor = do+  store <- readSTRef (dense editor)+  entries <-+    denseRankEntries+      store+      0+      (Mutable.length (rank store))+      []+  pure (IntMap.fromDistinctAscList entries)++denseRankEntries ::+  DenseStore state ->+  Int ->+  Int ->+  [(Int, Int)] ->+  ST state [(Int, Int)]+denseRankEntries store key limit entries+  | key >= limit =+      pure (reverse entries)+  | otherwise = do+      present <- Mutable.read (present store) key+      if present == denseFlagSet+        then do+          rankValue <- Mutable.read (rank store) key+          denseRankEntries+            store+            (key + 1)+            limit+            ((key, rankValue) : entries)+        else denseRankEntries store (key + 1) limit entries
+ src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Storage.hs view
@@ -0,0 +1,118 @@+-- | The dense↔sparse↔base dispatch seam: unified parent/rank reads and writes+-- that consult the dense arena first, then the sparse overlay, then the frozen+-- base, plus the class-identity writers that place a fresh key on the right tier.+module Moonlight.Core.UnionFind.Transaction.Internal.Storage+  ( readParentKey,+    readRankValue,+    writeParentKey,+    writeRankValue,+    writeFreshClassIdentity,+    writeSparseIdentity,+  )+where++import Control.Monad.ST (ST)+import Data.IntMap.Strict qualified as IntMap+import Data.STRef (modifySTRef', readSTRef)+import Moonlight.Core.Identifier.EGraph (ClassId (..), classIdKey)+import Moonlight.Core.UnionFind.Internal.Types (UnionFind (..))+import Moonlight.Core.UnionFind.Transaction.Internal.DenseStore+  ( ensureDenseCapacity,+    initializeDenseSlot,+    readDenseParentKey,+    readDenseRank,+    writeDenseParentIfPresent,+    writeDenseRankIfPresent,+  )+import Moonlight.Core.UnionFind.Transaction.Internal.Types+  ( UnionFindEditor (..),+  )+import Prelude++readParentKey ::+  UnionFindEditor state ->+  Int ->+  ST state (Maybe Int)+readParentKey editor key = do+  maybeDenseParent <- readDenseParentKey editor key+  case maybeDenseParent of+    Just parentKey ->+      pure (Just parentKey)+    Nothing -> do+      sparseWrites <- readSTRef (sparseParentWrites editor)+      case IntMap.lookup key sparseWrites of+        Just parentClassId ->+          pure (Just (classIdKey parentClassId))+        Nothing ->+          pure (fmap classIdKey (IntMap.lookup key (ufParent (base editor))))+{-# INLINE readParentKey #-}++readRankValue :: UnionFindEditor state -> Int -> ST state Int+readRankValue editor key = do+  maybeDenseRank <- readDenseRank editor key+  case maybeDenseRank of+    Just rankValue ->+      pure rankValue+    Nothing -> do+      sparseWrites <- readSTRef (sparseRankWrites editor)+      let baseRank = IntMap.findWithDefault 0 key (ufRank (base editor))+      pure (IntMap.findWithDefault baseRank key sparseWrites)+{-# INLINE readRankValue #-}++writeParentKey ::+  UnionFindEditor state ->+  Int ->+  Int ->+  ST state ()+writeParentKey editor childKey parentKey = do+  currentParent <- readParentKey editor childKey+  if currentParent == Just parentKey+    then pure ()+    else do+      wroteDense <- writeDenseParentIfPresent editor childKey parentKey+      if wroteDense+        then pure ()+        else+          modifySTRef'+            (sparseParentWrites editor)+            (IntMap.insert childKey (ClassId parentKey))+{-# INLINE writeParentKey #-}++writeRankValue ::+  UnionFindEditor state ->+  Int ->+  Int ->+  ST state ()+writeRankValue editor key rankValue = do+  currentRank <- readRankValue editor key+  if currentRank == rankValue+    then pure ()+    else do+      wroteDense <- writeDenseRankIfPresent editor key rankValue+      if wroteDense+        then pure ()+        else+          modifySTRef'+            (sparseRankWrites editor)+            (IntMap.insert key rankValue)+{-# INLINE writeRankValue #-}++writeFreshClassIdentity :: UnionFindEditor state -> Int -> ST state ()+writeFreshClassIdentity editor key = do+  denseReady <- ensureDenseCapacity editor key+  if denseReady+    then do+      initialized <- initializeDenseSlot editor key+      if initialized+        then pure ()+        else writeSparseIdentity editor key+    else writeSparseIdentity editor key++writeSparseIdentity :: UnionFindEditor state -> Int -> ST state ()+writeSparseIdentity editor key = do+  modifySTRef'+    (sparseParentWrites editor)+    (IntMap.insert key (ClassId key))+  modifySTRef'+    (sparseRankWrites editor)+    (IntMap.insert key 0)
+ src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Types.hs view
@@ -0,0 +1,64 @@+-- | Carrier types for the union-find transaction editor: the mutable dense+-- store, the sealed editor state token (with its nominal role), the union+-- outcome, and the dense sizing/flag constants.+module Moonlight.Core.UnionFind.Transaction.Internal.Types+  ( minimumDenseSlots,+    maximumDenseSlots,+    denseFlagUnset,+    denseFlagSet,+    DenseStore (..),+    UnionFindEditor (..),+    UnionOutcome (..),+  )+where++import Data.IntMap.Strict (IntMap)+import Data.Kind (Type)+import Data.STRef (STRef)+import Data.Vector.Unboxed.Mutable (MVector)+import Data.Word (Word8)+import Moonlight.Core.Identifier.EGraph (ClassId)+import Moonlight.Core.UnionFind.Internal.Types (UnionFind)+import Prelude++minimumDenseSlots :: Int+minimumDenseSlots = 64++maximumDenseSlots :: Int+maximumDenseSlots = 262144++denseFlagUnset :: Word8+denseFlagUnset = 0++denseFlagSet :: Word8+denseFlagSet = 1++type DenseStore :: Type -> Type+data DenseStore state = DenseStore+  { parent :: !(MVector state Int),+    rank :: !(MVector state Int),+    present :: !(MVector state Word8),+    parentDirty :: !(MVector state Word8),+    rankDirty :: !(MVector state Word8)+  }++type UnionFindEditor :: Type -> Type+data UnionFindEditor state = UnionFindEditor+  { base :: !UnionFind,+    dense :: !(STRef state (DenseStore state)),+    sparseParentWrites :: !(STRef state (IntMap ClassId)),+    sparseRankWrites :: !(STRef state (IntMap Int)),+    dirtyDenseParents :: !(STRef state [Int]),+    dirtyDenseRanks :: !(STRef state [Int]),+    dirtyDenseParentCount :: !(STRef state Int),+    dirtyDenseRankCount :: !(STRef state Int),+    denseMemberCount :: !(STRef state Int),+    nextFresh :: !(STRef state Integer)+  }++type role UnionFindEditor nominal++data UnionOutcome+  = AlreadyEquivalent !ClassId+  | MergedClasses !ClassId !ClassId+  deriving stock (Eq, Show)
+ src-syntax/Moonlight/Core/Fix/Order.hs view
@@ -0,0 +1,22 @@+-- | 'OrderedFix', a @newtype@ giving 'Eq' and 'Ord' for fixed-point terms over+-- any 'Language' functor by structural comparison.+module Moonlight.Core.Fix.Order+  ( OrderedFix (..),+  )+where++import Data.Fix (Fix (..))+import Data.Kind (Type)+import Moonlight.Core.Language (Language)+import Prelude (Eq ((==)), Functor (fmap), Ord (compare), Ordering (EQ))++type OrderedFix :: (Type -> Type) -> Type+newtype OrderedFix f = OrderedFix (Fix f)++instance Language f => Eq (OrderedFix f) where+  OrderedFix leftTerm == OrderedFix rightTerm =+    compare (OrderedFix leftTerm) (OrderedFix rightTerm) == EQ++instance Language f => Ord (OrderedFix f) where+  compare (OrderedFix (Fix leftNode)) (OrderedFix (Fix rightNode)) =+    compare (fmap OrderedFix leftNode) (fmap OrderedFix rightNode)
+ src-syntax/Moonlight/Core/Guidance.hs view
@@ -0,0 +1,65 @@+-- | Configuration and trace types for guided saturation: modes, checkpoints,+-- evidence, selections and per-round traces.+module Moonlight.Core.Guidance+  ( GuideMode (..),+    GuideCheckpoint (..),+    GuidanceConfig (..),+    GuideCheckpointHit (..),+    GuideEvidence (..),+    GuideSelection (..),+    GuideRoundTrace (..),+  )+where++import Data.Kind (Type)+import Prelude++type GuideMode :: Type+data GuideMode+  = GuidePrefer+  | GuideRequire+  deriving stock (Eq, Ord, Show, Read)++type GuideCheckpoint :: Type -> Type+data GuideCheckpoint patternValue = GuideCheckpoint+  { gcName :: String,+    gcMode :: GuideMode,+    gcTarget :: patternValue+  }++type GuidanceConfig :: Type -> Type+newtype GuidanceConfig patternValue = GuidanceConfig+  { gcCheckpoints :: [GuideCheckpoint patternValue]+  }++type GuideCheckpointHit :: Type -> Type+data GuideCheckpointHit classId = GuideCheckpointHit+  { gchCheckpointName :: String,+    gchMode :: GuideMode,+    gchPreviewClass :: classId+  }+  deriving stock (Eq, Ord, Show, Read)++type GuideEvidence :: Type -> Type+newtype GuideEvidence classId = GuideEvidence+  { geCheckpointHits :: [GuideCheckpointHit classId]+  }+  deriving stock (Eq, Ord, Show, Read)++type GuideSelection :: Type+data GuideSelection+  = GuidePassThrough+  | GuidePreferred+  | GuideRequired+  deriving stock (Eq, Ord, Show, Read)++type GuideRoundTrace :: Type+data GuideRoundTrace = GuideRoundTrace+  { grtIteration :: Int,+    grtEligibleCount :: Int,+    grtRetainedCount :: Int,+    grtGuidedCount :: Int,+    grtMatchedCheckpointCount :: Int,+    grtSelection :: GuideSelection+  }+  deriving stock (Eq, Ord, Show, Read)
+ src-syntax/Moonlight/Core/Language.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TypeFamilies #-}++module Moonlight.Core.Language+  ( ZipMatch (..),+    Language,+    sameNodeShape,+    zipSameNodeShape,+    HasConstructorTag (..),+  )+where++import Data.Foldable (toList)+import Data.Functor (void)+import Data.Kind (Constraint, Type)+import Data.Traversable (mapAccumL)+import Prelude (Bool, Maybe (Just, Nothing), Ord, Traversable, otherwise, sequenceA, (==))++type ZipMatch :: (Type -> Type) -> Constraint+-- | Structural one-layer matching. @zipMatch@ succeeds iff the two nodes have the same shape, aligning children positionally and pairing every child.+class Traversable f => ZipMatch f where+  zipMatch :: f left -> f right -> Maybe (f (left, right))++type Language :: (Type -> Type) -> Constraint+class (Traversable f, forall a. Ord a => Ord (f a)) => Language f++instance (Traversable f, forall a. Ord a => Ord (f a)) => Language f++sameNodeShape :: Language f => f left -> f right -> Bool+sameNodeShape leftNode rightNode =+  void leftNode == void rightNode++zipSameNodeShape ::+  Language f =>+  f left ->+  f right ->+  Maybe (f (left, right))+zipSameNodeShape leftNode rightNode+  | sameNodeShape leftNode rightNode =+      case mapAccumL consumeRightChild (toList rightNode) leftNode of+        ([], zippedNode) ->+          sequenceA zippedNode+        _ ->+          Nothing+  | otherwise =+      Nothing+  where+    consumeRightChild ::+      [right] ->+      left ->+      ([right], Maybe (left, right))+    consumeRightChild rightChildren leftChild =+      case rightChildren of+        rightChild : trailingRightChildren ->+          (trailingRightChildren, Just (leftChild, rightChild))+        [] ->+          ([], Nothing)++type HasConstructorTag :: (Type -> Type) -> Constraint+class (Language f, Ord (ConstructorTag f)) => HasConstructorTag f where+  type ConstructorTag f :: Type+  constructorTag :: f a -> ConstructorTag f
+ src-syntax/Moonlight/Core/Pattern.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE QuantifiedConstraints #-}++module Moonlight.Core.Pattern+  ( Pattern (..),+    patternVariables,+  )+where++import Data.Kind (Type)+import Data.Set (Set)+import Data.Set qualified as Set+import Moonlight.Core.Identifier.EGraph (PatternVar)+import Prelude (Eq (..), Foldable, Ord (..), Ordering (..), Show (..), foldMap, showParen, showString, ($), (.))++type Pattern :: (Type -> Type) -> Type+-- | Authored open syntax: either a pattern variable or a language node whose children are patterns.+data Pattern f+  = PatternVar PatternVar+  | PatternNode (f (Pattern f))++instance (forall a. Ord a => Ord (f a)) => Eq (Pattern f) where+  leftPattern == rightPattern = compare leftPattern rightPattern == EQ++instance (forall a. Ord a => Ord (f a)) => Ord (Pattern f) where+  compare leftPattern rightPattern =+    case (leftPattern, rightPattern) of+      (PatternVar leftVar, PatternVar rightVar) -> compare leftVar rightVar+      (PatternVar _, PatternNode _) -> LT+      (PatternNode _, PatternVar _) -> GT+      (PatternNode leftNode, PatternNode rightNode) -> compare leftNode rightNode++instance (forall a. Show a => Show (f a)) => Show (Pattern f) where+  showsPrec precedence patternValue =+    case patternValue of+      PatternVar patternVar ->+        showParen (precedence > 10) $+          showString "PatternVar " . showsPrec 11 patternVar+      PatternNode node ->+        showParen (precedence > 10) $+          showString "PatternNode " . showsPrec 11 node++patternVariables :: Foldable f => Pattern f -> Set PatternVar+patternVariables patternValue =+  case patternValue of+    PatternVar patternVar ->+      Set.singleton patternVar+    PatternNode node ->+      foldMap patternVariables node
+ src-syntax/Moonlight/Core/Pattern/AntiUnify.hs view
@@ -0,0 +1,239 @@+-- | Least-general-generalization runtime for concrete terms.+-- It owns binary and n-ary anti-unification, preserving shared constructor+-- structure and abstracting disagreements into fresh pattern variables with stored witnesses.+module Moonlight.Core.Pattern.AntiUnify+  ( BinaryLGGResult (..),+    NaryLGGResult (..),+    antiUnifyTerms,+    antiUnifyWithTermStore,+    antiUnifyAllTerms,+    antiUnifyAllWithTermStore,+  )+where++import Control.Monad.Trans.State.Strict (StateT (..), runStateT)+import Data.Fix (Fix (..))+import Data.Foldable (foldlM)+import Data.Functor.Identity (Identity (..), runIdentity)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Moonlight.Core.Identifier.EGraph+  ( PatternVar,+    mkPatternVar,+    patternVarKey,+  )+import Moonlight.Core.Language (ZipMatch (..))+import Moonlight.Core.Pattern (Pattern (..))+import Prelude++type BinaryLGGResult :: (Type -> Type) -> Type -> Type+data BinaryLGGResult f binding = BinaryLGGResult+  { binaryLggPattern :: !(Pattern f),+    binaryLggLeftBindings :: !(IntMap binding),+    binaryLggRightBindings :: !(IntMap binding),+    binaryLggSharedStructure :: !Int+  }++deriving stock instance (Eq (Pattern f), Eq binding) => Eq (BinaryLGGResult f binding)+deriving stock instance (Show (Pattern f), Show binding) => Show (BinaryLGGResult f binding)++type NaryLGGResult :: (Type -> Type) -> Type -> Type+data NaryLGGResult f binding = NaryLGGResult+  { naryLggPattern :: !(Pattern f),+    naryLggBindings :: !(NonEmpty (IntMap binding)),+    naryLggSharedStructure :: !Int+  }++deriving stock instance (Eq (Pattern f), Eq binding) => Eq (NaryLGGResult f binding)+deriving stock instance (Show (Pattern f), Show binding) => Show (NaryLGGResult f binding)++type BinaryAntiUnifyState :: Type -> Type -> Type+data BinaryAntiUnifyState store binding = BinaryAntiUnifyState+  { bausNextVar :: !PatternVar,+    bausStore :: !store,+    bausLeftBindings :: !(IntMap binding),+    bausRightBindings :: !(IntMap binding),+    bausSharedStructure :: !Int+  }++type NaryAntiUnifyState :: Type -> Type -> Type+data NaryAntiUnifyState store binding = NaryAntiUnifyState+  { nautsNextVar :: !PatternVar,+    nautsStore :: !store,+    nautsBindings :: !(NonEmpty (IntMap binding)),+    nautsSharedStructure :: !Int+  }++antiUnifyAllTerms :: ZipMatch f => NonEmpty (Fix f) -> NaryLGGResult f (Fix f)+antiUnifyAllTerms terms =+  fst+    ( runIdentity+        (antiUnifyAllWithTermStore (\termValue storeValue -> Identity (termValue, storeValue)) () terms)+    )++antiUnifyAllWithTermStore ::+  (ZipMatch f, Monad effect) =>+  (Fix f -> store -> effect (binding, store)) ->+  store ->+  NonEmpty (Fix f) ->+  effect (NaryLGGResult f binding, store)+antiUnifyAllWithTermStore insertTerm initialStore terms = do+  let initialState =+        NaryAntiUnifyState+          { nautsNextVar = mkPatternVar 0,+            nautsStore = initialStore,+            nautsBindings = fmap (const IntMap.empty) terms,+            nautsSharedStructure = 0+          }+  (patternValue, finalState) <- antiUnifyAllRecursive insertTerm terms initialState+  pure (lggFromNaryState patternValue finalState, nautsStore finalState)++antiUnifyAllRecursive ::+  (ZipMatch f, Monad effect) =>+  (Fix f -> store -> effect (binding, store)) ->+  NonEmpty (Fix f) ->+  NaryAntiUnifyState store binding ->+  effect (Pattern f, NaryAntiUnifyState store binding)+antiUnifyAllRecursive insertTerm terms state =+  case alignedChildLayer terms of+    Just childLayer -> do+      (childPatterns, childState) <-+        runStateT+          (traverse (StateT . antiUnifyAllRecursive insertTerm) childLayer)+          state+      pure (PatternNode childPatterns, childState {nautsSharedStructure = nautsSharedStructure childState + 1})+    Nothing ->+      freshNaryVariable insertTerm terms state++alignedChildLayer :: ZipMatch f => NonEmpty (Fix f) -> Maybe (f (NonEmpty (Fix f)))+alignedChildLayer terms =+  case NonEmpty.reverse terms of+    Fix lastLayer :| reversedLeadingTerms ->+      foldlM+        prependAlignedChildren+        (fmap NonEmpty.singleton lastLayer)+        reversedLeadingTerms++prependAlignedChildren :: ZipMatch f => f (NonEmpty (Fix f)) -> Fix f -> Maybe (f (NonEmpty (Fix f)))+prependAlignedChildren accumulatedRows (Fix nextLayer) =+  fmap+    (fmap prependAlignedChild)+    (zipMatch nextLayer accumulatedRows)++prependAlignedChild :: (child, NonEmpty child) -> NonEmpty child+prependAlignedChild (nextChild, accumulatedRow) =+  NonEmpty.cons nextChild accumulatedRow++freshNaryVariable ::+  Monad effect =>+  (Fix f -> store -> effect (binding, store)) ->+  NonEmpty (Fix f) ->+  NaryAntiUnifyState store binding ->+  effect (Pattern f, NaryAntiUnifyState store binding)+freshNaryVariable insertTerm terms state = do+  let patternVar = nautsNextVar state+  (bindings, storeAfterTerms) <-+    runStateT+      (traverse (StateT . insertTerm) terms)+      (nautsStore state)+  let+      nextState =+        state+          { nautsNextVar = succ patternVar,+            nautsStore = storeAfterTerms,+            nautsBindings =+              NonEmpty.zipWith+                (IntMap.insert (patternVarKey patternVar))+                bindings+                (nautsBindings state)+          }+  pure (PatternVar patternVar, nextState)++lggFromNaryState :: Pattern f -> NaryAntiUnifyState store binding -> NaryLGGResult f binding+lggFromNaryState patternValue state =+  NaryLGGResult+    { naryLggPattern = patternValue,+      naryLggBindings = nautsBindings state,+      naryLggSharedStructure = nautsSharedStructure state+    }++antiUnifyTerms :: ZipMatch f => Fix f -> Fix f -> BinaryLGGResult f (Fix f)+antiUnifyTerms leftTerm rightTerm =+  fst+    ( runIdentity+        (antiUnifyWithTermStore (\termValue storeValue -> Identity (termValue, storeValue)) () leftTerm rightTerm)+    )++antiUnifyWithTermStore ::+  (ZipMatch f, Monad effect) =>+  (Fix f -> store -> effect (binding, store)) ->+  store ->+  Fix f ->+  Fix f ->+  effect (BinaryLGGResult f binding, store)+antiUnifyWithTermStore insertTerm initialStore leftTerm rightTerm = do+  let initialState =+        BinaryAntiUnifyState+          { bausNextVar = mkPatternVar 0,+            bausStore = initialStore,+            bausLeftBindings = IntMap.empty,+            bausRightBindings = IntMap.empty,+            bausSharedStructure = 0+          }+  (patternValue, finalState) <- antiUnifyRecursive insertTerm leftTerm rightTerm initialState+  pure (lggFromState patternValue finalState, bausStore finalState)++antiUnifyRecursive ::+  (ZipMatch f, Monad effect) =>+  (Fix f -> store -> effect (binding, store)) ->+  Fix f ->+  Fix f ->+  BinaryAntiUnifyState store binding ->+  effect (Pattern f, BinaryAntiUnifyState store binding)+antiUnifyRecursive insertTerm leftTerm@(Fix leftLayer) rightTerm@(Fix rightLayer) state =+  case zipMatch leftLayer rightLayer of+    Just matchedChildren -> do+      (childPatterns, childState) <-+        runStateT+          ( traverse+              (\(leftChild, rightChild) -> StateT (antiUnifyRecursive insertTerm leftChild rightChild))+              matchedChildren+          )+          state+      pure (PatternNode childPatterns, childState {bausSharedStructure = bausSharedStructure childState + 1})+    Nothing ->+      freshVariable insertTerm leftTerm rightTerm state++freshVariable ::+  Monad effect =>+  (Fix f -> store -> effect (binding, store)) ->+  Fix f ->+  Fix f ->+  BinaryAntiUnifyState store binding ->+  effect (Pattern f, BinaryAntiUnifyState store binding)+freshVariable insertTerm leftTerm rightTerm state = do+  let patternVar = bausNextVar state+      patternKey = patternVarKey patternVar+  (leftBinding, storeAfterLeft) <- insertTerm leftTerm (bausStore state)+  (rightBinding, storeAfterRight) <- insertTerm rightTerm storeAfterLeft+  let+      nextState =+        state+          { bausNextVar = succ patternVar,+            bausStore = storeAfterRight,+            bausLeftBindings = IntMap.insert patternKey leftBinding (bausLeftBindings state),+            bausRightBindings = IntMap.insert patternKey rightBinding (bausRightBindings state)+          }+  pure (PatternVar patternVar, nextState)++lggFromState :: Pattern f -> BinaryAntiUnifyState store binding -> BinaryLGGResult f binding+lggFromState patternValue state =+  BinaryLGGResult+    { binaryLggPattern = patternValue,+      binaryLggLeftBindings = bausLeftBindings state,+      binaryLggRightBindings = bausRightBindings state,+      binaryLggSharedStructure = bausSharedStructure state+    }
+ src-syntax/Moonlight/Core/Site/Program.hs view
@@ -0,0 +1,43 @@+-- | Context-indexed rule programs, splitting rules into a base and per-context+-- refinements.+module Moonlight.Core.Site.Program+  ( SiteIndex (..),+    MatchActivationIndex (..),+    SupportIndexedRule (..),+    SiteProgram (..),+  )+where++import Data.Kind (Type)+import Data.Map.Strict (Map)+import Data.Set (Set)+import Prelude (Eq, Ord, Show)++type SiteIndex :: Type -> Type -> Type+data SiteIndex c rule = SiteIndex+  { siBase :: ![rule],+    siContexts :: !(Map c [rule])+  }++type MatchActivationIndex :: Type -> Type -> Type+data MatchActivationIndex c ruleId = MatchActivationIndex+  { maiBase :: !(Set ruleId),+    maiContexts :: !(Map c (Set ruleId))+  }++type SupportIndexedRule :: Type -> Type -> Type+data SupportIndexedRule support rule = SupportIndexedRule+  { sirSupport :: !support,+    sirRule :: !rule+  }+  deriving stock (Eq, Ord, Show)++type SiteProgram :: Type -> Type -> Type -> Type -> Type -> Type+data SiteProgram c rewriteRule factRule ruleId support = SiteProgram+  { spFactRules :: !(SiteIndex c factRule),+    spRewriteRules :: !(SiteIndex c rewriteRule),+    spSupportedFactRules :: ![SupportIndexedRule support factRule],+    spSupportedRewriteRules :: !(Map ruleId (SupportIndexedRule support rewriteRule)),+    spRewriteActivation :: !(MatchActivationIndex c ruleId),+    spBaseRewriteSupport :: !(Map ruleId support)+  }
+ src-syntax/Moonlight/Core/Substitution.hs view
@@ -0,0 +1,85 @@+-- | Pattern-variable substitutions ('Substitution', a map from variables to+-- class identifiers).+module Moonlight.Core.Substitution+  ( Substitution (..),+    emptySubstitution,+    insertSubst,+    lookupSubst,+    mapSubstitutionClasses,+    extendSubst,+    mergeSubstitutions,+    intersectRootedMatches,+  )+where++import Data.Kind (Type)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.List.NonEmpty qualified as NonEmpty+import Moonlight.Core.Identifier.EGraph (ClassId, PatternVar, classIdKey, mkPatternVar, patternVarKey)+import Prelude++type Substitution :: Type+newtype Substitution = Substitution (IntMap ClassId)+  deriving stock (Eq, Ord, Show)++emptySubstitution :: Substitution+emptySubstitution =+  Substitution IntMap.empty++lookupSubst :: PatternVar -> Substitution -> Maybe ClassId+lookupSubst patternVar (Substitution entries) =+  IntMap.lookup (patternVarKey patternVar) entries++insertSubst :: PatternVar -> ClassId -> Substitution -> Substitution+insertSubst patternVar classId (Substitution entries) =+  Substitution (IntMap.insert (patternVarKey patternVar) classId entries)++mapSubstitutionClasses :: (ClassId -> ClassId) -> Substitution -> Substitution+mapSubstitutionClasses mapClassId (Substitution entries) =+  Substitution (IntMap.map mapClassId entries)++extendSubst :: PatternVar -> ClassId -> Substitution -> Maybe Substitution+extendSubst patternVar classId substitution =+  case lookupSubst patternVar substitution of+    Nothing ->+      Just (insertSubst patternVar classId substitution)+    Just existingClassId+      | existingClassId == classId ->+          Just substitution+      | otherwise ->+          Nothing++mergeSubstitutions :: Substitution -> Substitution -> Maybe Substitution+mergeSubstitutions substitution (Substitution newEntries) =+  IntMap.foldrWithKey+    ( \patternKey classId mergeRemaining currentSubstitution ->+        extendSubst (mkPatternVar patternKey) classId currentSubstitution >>= mergeRemaining+    )+    Just+    newEntries+    substitution++intersectRootedMatches :: NonEmpty.NonEmpty [(ClassId, Substitution)] -> [(ClassId, Substitution)]+intersectRootedMatches rootedMatches =+  case rootedMatches of+    initialMatches NonEmpty.:| remainingMatches ->+      foldl' intersectRootedMatchSet initialMatches remainingMatches++intersectRootedMatchSet :: [(ClassId, Substitution)] -> [(ClassId, Substitution)] -> [(ClassId, Substitution)]+intersectRootedMatchSet leftMatches rightMatches =+  leftMatches+    >>= \(leftClassId, leftSubstitution) ->+      IntMap.findWithDefault [] (classIdKey leftClassId) rightMatchesByClass+        >>= \rightSubstitution ->+          maybe+            []+            (\mergedSubstitution -> [(leftClassId, mergedSubstitution)])+            (mergeSubstitutions leftSubstitution rightSubstitution)+  where+    rightMatchesByClass =+      foldr insertRightSubstitution IntMap.empty rightMatches++    insertRightSubstitution :: (ClassId, substitution) -> IntMap.IntMap [substitution] -> IntMap.IntMap [substitution]+    insertRightSubstitution (rightClassId, rightSubstitution) =+      IntMap.insertWith (<>) (classIdKey rightClassId) [rightSubstitution]
+ src-syntax/Moonlight/Core/Theory.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | The cheaply-canonicalizable slice of equational theory over a 'Language':+-- 'StructuralLaw' names node shapes whose canonical form is a sort (commutativity today).+-- Arbitrary equations belong to the e-graph layer, not here.+module Moonlight.Core.Theory+  ( StructuralLaw (..),+    TheorySpec (..),+    emptyTheorySpec,+    commutativeBinary,+    canonicalizeLayerByTheory,+    canonicalizePatternByTheory,+    expandPatternByTheory,+  )+where++import Data.Foldable (Foldable, toList)+import Data.Kind (Type)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Traversable (traverse)+import Moonlight.Core.Language (Language)+import Moonlight.Core.Pattern (Pattern (..))+import Prelude (Ord (..), const, (.), (<$>))++type StructuralLaw :: (Type -> Type) -> Type -> Type+data StructuralLaw f a+  = Ordinary+  | CommutativeBinary !(a -> a -> f a)++type TheorySpec :: (Type -> Type) -> Type+data TheorySpec f = TheorySpec+  { tsClassify :: forall a. f a -> StructuralLaw f a+  }++emptyTheorySpec :: TheorySpec f+emptyTheorySpec = TheorySpec {tsClassify = const Ordinary}++commutativeBinary :: (a -> a -> f a) -> StructuralLaw f a+commutativeBinary =+  CommutativeBinary++canonicalizeLayerByTheory :: (Foldable f, Ord a) => TheorySpec f -> f a -> f a+canonicalizeLayerByTheory spec node =+  case tsClassify spec node of+    Ordinary -> node+    CommutativeBinary law -> canonicalizeCommutativeBinary law node++canonicalizePatternByTheory :: Language f => TheorySpec f -> Pattern f -> Pattern f+canonicalizePatternByTheory spec patternValue =+  case patternValue of+    PatternVar patternVar ->+      PatternVar patternVar+    PatternNode node ->+      PatternNode (canonicalizeLayerByTheory spec (canonicalizePatternByTheory spec <$> node))++canonicalizeCommutativeBinary :: (Foldable f, Ord a) => (a -> a -> f a) -> f a -> f a+canonicalizeCommutativeBinary rebuild node =+  case toList node of+    [left, right] ->+      if right < left+        then rebuild right left+        else rebuild left right+    _ -> node++expandPatternByTheory :: forall f. Language f => TheorySpec f -> Pattern f -> [Pattern f]+expandPatternByTheory spec =+  Set.toList . expandPatternOrbit+  where+    expandPatternOrbit :: Pattern f -> Set (Pattern f)+    expandPatternOrbit patternValue =+      case patternValue of+        PatternVar patternVar ->+          Set.singleton (PatternVar patternVar)+        PatternNode node ->+          Set.unions (localPatternNodeOrbit <$> traverse (Set.toList . expandPatternOrbit) node)++    localPatternNodeOrbit :: f (Pattern f) -> Set (Pattern f)+    localPatternNodeOrbit node =+      Set.map PatternNode (commutedNodeOrbit (tsClassify spec node) node)++    commutedNodeOrbit :: StructuralLaw f (Pattern f) -> f (Pattern f) -> Set (f (Pattern f))+    commutedNodeOrbit (CommutativeBinary rebuild) node =+      case toList node of+        [left, right] ->+          Set.fromList [node, rebuild right left]+        _ -> Set.singleton node+    commutedNodeOrbit Ordinary node =+      Set.singleton node
+ src-term/Moonlight/Core/Term/Database.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A relational term database: one encoded row table per operator. Rows own+-- facts; indexes are row-id/result access paths. Per operator, one always-current+-- exact map (children to results) carries insert dedup; the other indices defer+-- behind a private row-id watermark and fold in on first read. The public+-- monotone commit frontier is 'TermCommitResult.insertedRows'; the watermark is+-- merely index-refresh bookkeeping. Query arrangements are prefix tries, forced+-- per level and cached on the threaded 'Database'. Shape: egg's rebuilding+-- (POPL 2021), egglog's functional tables (PLDI 2023), Free Join's lazy column+-- tries (SIGMOD 2023).+module Moonlight.Core.Term.Database+  ( Operator (..),+    extractOperator,+    RowId,+    RowIdSet,+    DatabaseRow,+    rowResult,+    rowChildren,+    mapRowKeys,+    DatabaseRowDelta (..),+    TermCommitResult (..),+    TermCommand (..),+    Column (..),+    ArrangementKey,+    ArrangementValidationError (..),+    arrangementKeyForOperator,+    arrangementKeyColumns,+    ArrangementPrefix,+    arrangementPrefixForKey,+    ArrangementNode (..),+    Arrangement (..),+    RelationStats (..),+    QueryVar (..),+    QueryTerm (..),+    QueryAtom (..),+    FreeJoinPlan (..),+    FreeJoinStrategy (..),+    QueryBinding (..),+    PatternFreeJoinPlan (..),+    Database,+    DatabaseEditor,+    TupleLookup (..),+    emptyDatabase,+    runCommandTransaction,+    editorSnapshot,+    editorQueueCommands,+    editorInsertTuple,+    editorDeleteRow,+    editorDeleteTuple,+    editorReplaceTuple,+    editorCompact,+    abortTransaction,+    insertTuple,+    insertTuples,+    deleteRow,+    deleteTuple,+    normalizeTermCommands,+    commitTermCommands,+    compact,+    dirtyRowsForKeys,+    operatorRows,+    resultKeys,+    resultKeysUsingAnyChildKey,+    operatorRowsForIds,+    rowsForOperator,+    rowsForResultKeys,+    arrangementRowsForPrefix,+    relationStats,+    compilePatternFreeJoinPlan,+    compilePatternsFreeJoinPlan,+    freeJoinStrategy,+    freeJoin,+    rowEntry,+    databaseEntries,+    entriesForResultKey,+    rehydrateTuple,+    lookupTupleAll,+    lookupTupleUnique,+    lookupLeastTuple,+  )+where++import Moonlight.Core.Term.Database.Arrangement+import Moonlight.Core.Term.Database.Command+import Moonlight.Core.Term.Database.FreeJoin+import Moonlight.Core.Term.Database.Lookup+import Moonlight.Core.Term.Database.Pattern+import Moonlight.Core.Term.Database.Projection+import Moonlight.Core.Term.Database.Table+import Moonlight.Core.Term.Database.Transaction+import Moonlight.Core.Term.Database.Types
+ src-term/Moonlight/Core/Term/Database/Arrangement.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE QuantifiedConstraints #-}++module Moonlight.Core.Term.Database.Arrangement 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.Foldable (traverse_)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe)+import Data.Primitive.SmallArray qualified as SmallArray+import Data.Set qualified as Set+import Data.Vector.Unboxed qualified as U+import Moonlight.Core.Term.Database.Index+import Moonlight.Core.Term.Database.OperatorTable+import Moonlight.Core.Term.Database.Table+import Moonlight.Core.Term.Database.Types+import Prelude++arrangementRowsForPrefix ::+  (Foldable f, forall a. Ord a => Ord (f a)) =>+  Operator f ->+  ArrangementKey ->+  ArrangementPrefix ->+  Database f key ->+  Either ArrangementValidationError ([(RowId, DatabaseRow)], Database f key)+arrangementRowsForPrefix operator key prefix database =+  arrangementRowsForResolvedOperator+    (operatorIdFor operator database)+    operator+    key+    prefix+    database++arrangementRowsForResolvedOperator ::+  Foldable f =>+  Maybe Int ->+  Operator f ->+  ArrangementKey ->+  ArrangementPrefix ->+  Database f key ->+  Either ArrangementValidationError ([(RowId, DatabaseRow)], Database f key)+arrangementRowsForResolvedOperator resolvedOperatorId operator key prefix database = do+  validateArrangementKeyForOperator operator key+  validateArrangementPrefixForKey key prefix+  pure $+    case resolvedOperatorId of+      Nothing ->+        ([], database)+      Just operatorId ->+        let refreshedDatabase =+              ensureOperatorDerivedIndexes operatorId database+         in case IntMap.lookup operatorId (operatorTables refreshedDatabase) of+              Nothing ->+                ([], refreshedDatabase)+              Just refreshedTable ->+                let (rowIds, arrangedDatabase) =+                      forceArrangementPrefix operatorId key prefix refreshedTable refreshedDatabase+                 in (rowsForIds refreshedTable rowIds, arrangedDatabase)++relationStats ::+  (Foldable f, forall a. Ord a => Ord (f a)) =>+  [ArrangementKey] ->+  Operator f ->+  Database f key ->+  Either ArrangementValidationError (Maybe RelationStats)+relationStats prefixKeys operator database =+  traverse_ (validateArrangementKeyForOperator operator) prefixKeys+    *> Right+      ( operatorIdFor operator database+          >>= \operatorId ->+            fmap+              (operatorRelationStats prefixKeys)+              (IntMap.lookup operatorId (operatorTables database))+      )++forceArrangementPrefix ::+  Int ->+  ArrangementKey ->+  ArrangementPrefix ->+  OperatorTable f ->+  Database f key ->+  (RowIdSet, Database f key)+forceArrangementPrefix operatorId key prefix table database =+  case cachedArrangementRows prefix =<< cachedArrangement operatorId key database of+    Just rowIds ->+      (rowIds, database)+    Nothing ->+      let arrangement =+            fromMaybe+              (emptyArrangement key (tableLiveRows table))+              (cachedArrangement operatorId key database)+          forcedArrangement =+            forceArrangementPrefixLevel table key prefix arrangement+          rowIds =+            fromMaybe emptyRowIdSet (cachedArrangementRows prefix forcedArrangement)+       in (rowIds, storeArrangement operatorId forcedArrangement database)++cachedArrangement :: Int -> ArrangementKey -> Database f key -> Maybe Arrangement+cachedArrangement operatorId key database =+  Map.lookup key =<< IntMap.lookup operatorId (arrangements database)+{-# INLINE cachedArrangement #-}++cachedArrangementRows :: ArrangementPrefix -> Arrangement -> Maybe RowIdSet+cachedArrangementRows (ArrangementPrefix prefixValues) arrangement =+  arrangementNodeRowsForPrefix prefixValues (arrangementRoot arrangement)+{-# INLINE cachedArrangementRows #-}++emptyArrangement :: ArrangementKey -> RowIdSet -> Arrangement+emptyArrangement key rowIds =+  Arrangement+    { arrangementOrder = key,+      arrangementRoot = OffsetLeaf rowIds+    }+{-# INLINE emptyArrangement #-}++forceArrangementPrefixLevel :: OperatorTable f -> ArrangementKey -> ArrangementPrefix -> Arrangement -> Arrangement+forceArrangementPrefixLevel table key (ArrangementPrefix prefixValues) arrangement =+  arrangement+    { arrangementRoot = forcedRoot+    }+  where+    forcedRoot =+      fromMaybe+        (arrangementRoot arrangement)+        (forceArrangementNode table key 0 prefixValues (arrangementRoot arrangement))+{-# INLINE forceArrangementPrefixLevel #-}++arrangementNodeRowsForPrefix :: [Int] -> ArrangementNode -> Maybe RowIdSet+arrangementNodeRowsForPrefix prefixValues node =+  case prefixValues of+    [] ->+      Just (arrangementNodeRows node)+    prefixValue : remainingPrefix ->+      case node of+        OffsetLeaf _rowIds ->+          Nothing+        PrefixBranch _rowIds branches ->+          Map.lookup prefixValue branches >>= arrangementNodeRowsForPrefix remainingPrefix+{-# INLINE arrangementNodeRowsForPrefix #-}++forceArrangementNode :: OperatorTable f -> ArrangementKey -> Int -> [Int] -> ArrangementNode -> Maybe ArrangementNode+forceArrangementNode table key depth prefixValues node =+  case prefixValues of+    [] ->+      Just node+    prefixValue : remainingPrefix -> do+      column <- arrangementColumnAt depth key+      let rowIds =+            arrangementNodeRows node+          branches =+            arrangementNodeBranches node+          childNode =+            Map.findWithDefault+              (OffsetLeaf (prefixChildRows table column prefixValue rowIds))+              prefixValue+              branches+      forcedChild <- forceArrangementNode table key (depth + 1) remainingPrefix childNode+      Just (PrefixBranch rowIds (Map.insert prefixValue forcedChild branches))+{-# INLINE forceArrangementNode #-}++arrangementNodeRows :: ArrangementNode -> RowIdSet+arrangementNodeRows node =+  case node of+    OffsetLeaf rowIds ->+      rowIds+    PrefixBranch rowIds _branches ->+      rowIds+{-# INLINE arrangementNodeRows #-}++arrangementNodeBranches :: ArrangementNode -> Map Int ArrangementNode+arrangementNodeBranches node =+  case node of+    OffsetLeaf _rowIds ->+      Map.empty+    PrefixBranch _rowIds branches ->+      branches+{-# INLINE arrangementNodeBranches #-}++arrangementColumnAt :: Int -> ArrangementKey -> Maybe Column+arrangementColumnAt depth key+  | depth < 0 =+      Nothing+  | otherwise =+      columnAt depth (arrangementKeyColumns key)+{-# INLINE arrangementColumnAt #-}++columnAt :: Int -> [Column] -> Maybe Column+columnAt depth columns =+  case drop depth columns of+    column : _remainingColumns ->+      Just column+    [] ->+      Nothing+{-# INLINE columnAt #-}++prefixChildRows :: OperatorTable f -> Column -> Int -> RowIdSet -> RowIdSet+prefixChildRows table column prefixValue rowIds =+  rowIdSetIntersection rowIds (columnValueRows table column prefixValue)+{-# INLINE prefixChildRows #-}++columnValueRows :: OperatorTable f -> Column -> Int -> RowIdSet+columnValueRows table column value =+  case column of+    ResultColumn ->+      lookupResultIndex value (derivedResultIndex table)+    ChildColumn childIndex ->+      maybe+        emptyRowIdSet+        (RowIdSet . IntMap.findWithDefault IntSet.empty value)+        (childColumnValueIndexAt childIndex (derivedChildColumnValueIndex table))+{-# INLINE columnValueRows #-}++storeArrangement :: Int -> Arrangement -> Database f key -> Database f key+storeArrangement operatorId arrangement database =+  database+    { arrangements =+        IntMap.alter+          (Just . Map.insert (arrangementOrder arrangement) arrangement . fromMaybe Map.empty)+          operatorId+          (arrangements database)+    }+{-# INLINE storeArrangement #-}++databaseRowArrangementValues :: ArrangementKey -> DatabaseRow -> Maybe [Int]+databaseRowArrangementValues key row =+  traverse columnValue (arrangementKeyColumns key)+  where+    columnValue ResultColumn = Just (rowResult row)+    columnValue (ChildColumn childIndex) = childValueAt childIndex (rowChildrenArray row)+{-# INLINE databaseRowArrangementValues #-}++childColumnValueIndexAt :: Int -> ChildColumnValueIndex -> Maybe (IntMap IntSet)+childColumnValueIndexAt childIndex childColumnIndexes+  | childIndex < 0 = Nothing+  | otherwise =+      case childColumnIndexes of+        NullaryChildColumnValueIndex ->+          Nothing+        UnaryChildColumnValueIndex values+          | childIndex == 0 -> Just values+          | otherwise -> Nothing+        BinaryChildColumnValueIndex leftValues rightValues+          | childIndex == 0 -> Just leftValues+          | childIndex == 1 -> Just rightValues+          | otherwise -> Nothing+        NaryChildColumnValueIndex values+          | childIndex >= SmallArray.sizeofSmallArray values -> Nothing+          | otherwise -> Just (SmallArray.indexSmallArray values childIndex)+{-# INLINE childColumnValueIndexAt #-}++operatorRelationStats :: [ArrangementKey] -> OperatorTable f -> RelationStats+operatorRelationStats prefixKeys table =+  RelationStats+    { rowCount = nextRowId table,+      liveRowCount = rowIdSetSize (tableLiveRows table),+      distinctPerColumn =+        U.fromList (fmap (distinctColumnValueCount table) relationColumns),+      distinctPerPrefix =+        Map.fromList+          (fmap (\key -> (key, distinctArrangementPrefixCount table key)) prefixKeys),+      maximumBucketSize = maximumExactBucketSize table+    }+  where+    relationColumns =+      ResultColumn : fmap ChildColumn (ascendingRowKeys (opArity table))+{-# INLINE operatorRelationStats #-}++distinctColumnValueCount :: OperatorTable f -> Column -> Int+distinctColumnValueCount table column =+  IntMap.size indexedColumnValues+    + IntSet.foldl'+      countUnindexedColumnValue+      0+      unindexedColumnValues+  where+    indexedColumnValues =+      case column of+        ResultColumn ->+          derivedResultIndex table+        ChildColumn childIndex ->+          fromMaybe+            IntMap.empty+            (childColumnValueIndexAt childIndex (derivedChildColumnValueIndex table))++    unindexedColumnValues =+      foldUnindexedOperatorTableRowsWithId+        (\values _rowKey row -> insertUnindexedColumnValue values row)+        IntSet.empty+        table++    insertUnindexedColumnValue values row =+      maybe values (`IntSet.insert` values) (unindexedColumnValue row)++    countUnindexedColumnValue count value+      | IntMap.member value indexedColumnValues = count+      | otherwise = count + 1++    unindexedColumnValue row =+      case column of+        ResultColumn ->+          Just (rowResult row)+        ChildColumn childIndex+          | childIndex < 0 -> Nothing+          | otherwise -> childValueAt childIndex (rowChildrenArray row)+{-# INLINE distinctColumnValueCount #-}++distinctArrangementPrefixCount :: OperatorTable f -> ArrangementKey -> Int+distinctArrangementPrefixCount table key =+  Set.size $+    foldOperatorTableRowsWithId+      insertArrangementValue+      Set.empty+      table+  where+    insertArrangementValue values _rowKey row =+      maybe values (`Set.insert` values) (databaseRowArrangementValues key row)+{-# INLINE distinctArrangementPrefixCount #-}++maximumExactBucketSize :: OperatorTable f -> Int+maximumExactBucketSize =+  maximumChildTupleBucketSize . exactResultIx+{-# INLINE maximumExactBucketSize #-}++maximumChildTupleBucketSize :: ChildTupleIndex -> Int+maximumChildTupleBucketSize childTupleIndex =+  case childTupleIndex of+    NullaryChildTupleIndex keys ->+      IntSet.size keys+    UnaryChildTupleIndex byChild ->+      IntMap.foldl' maximumBucket 0 byChild+    BinaryChildTupleIndex byLeftChild ->+      IntMap.foldl' (\maximumSize byRightChild -> IntMap.foldl' maximumBucket maximumSize byRightChild) 0 byLeftChild+    NaryChildTupleIndex byChildren ->+      Map.foldl' maximumBucket 0 byChildren+  where+    maximumBucket maximumSize keys =+      max maximumSize (IntSet.size keys)+{-# INLINE maximumChildTupleBucketSize #-}
+ src-term/Moonlight/Core/Term/Database/Atom.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE BangPatterns #-}++module Moonlight.Core.Term.Database.Atom where++import Control.Monad (foldM)+import Data.Map.Strict qualified as Map+import Data.Primitive.PrimArray qualified as PrimArray+import Moonlight.Core.DenseKey (DenseKey (..))+import Moonlight.Core.Term.Database.Types+import Prelude++boundColumn :: DenseKey key => QueryBinding key -> (Column, QueryTerm key) -> Maybe (Column, Int)+boundColumn binding (column, term) =+  fmap (\value -> (column, value)) (termBoundValue binding term)+{-# INLINE boundColumn #-}++termBoundValue :: DenseKey key => QueryBinding key -> QueryTerm key -> Maybe Int+termBoundValue binding term =+  case term of+    QueryBound key ->+      Just (encodeDenseKey key)+    QueryVariable variable ->+      fmap encodeDenseKey (Map.lookup variable (queryBindingAssignments binding))+{-# INLINE termBoundValue #-}++atomArity :: QueryAtom f key -> Int+atomArity atom =+  length (atomChildren atom)+{-# INLINE atomArity #-}++atomColumns :: QueryAtom f key -> [Column]+atomColumns atom =+  ResultColumn : fmap ChildColumn [0 .. atomArity atom - 1]+{-# INLINE atomColumns #-}++atomTerms :: QueryAtom f key -> [QueryTerm key]+atomTerms atom =+  atomResult atom : atomChildren atom+{-# INLINE atomTerms #-}++atomBindRow ::+  DenseKey key =>+  QueryAtom f key ->+  QueryBinding key ->+  DatabaseRow ->+  Maybe (QueryBinding key)+atomBindRow atom binding row =+  if atomArity atom == PrimArray.sizeofPrimArray children+    then do+      resultBinding <- bindTermValue binding (atomResult atom, rowResult row)+      snd <$> foldM bindChild (0, resultBinding) (atomChildren atom)+    else Nothing+  where+    children =+      rowChildrenArray row+    bindChild (!childIndex, !currentBinding) childTerm =+      fmap+        (\nextBinding -> (childIndex + 1, nextBinding))+        ( bindTermValue+            currentBinding+            (childTerm, PrimArray.indexPrimArray children childIndex)+        )+{-# INLINE atomBindRow #-}++bindTermValue :: DenseKey key => QueryBinding key -> (QueryTerm key, Int) -> Maybe (QueryBinding key)+bindTermValue binding (term, encodedValue) =+  case term of+    QueryBound key+      | encodeDenseKey key == encodedValue ->+          Just binding+      | otherwise ->+          Nothing+    QueryVariable variable ->+      bindVariableValue variable encodedValue binding+{-# INLINE bindTermValue #-}++bindVariableValue :: DenseKey key => QueryVar -> Int -> QueryBinding key -> Maybe (QueryBinding key)+bindVariableValue variable encodedValue binding =+  case Map.lookup variable (queryBindingAssignments binding) of+    Nothing ->+      Just+        binding+          { queryBindingAssignments =+              Map.insert variable (decodeDenseKey encodedValue) (queryBindingAssignments binding)+          }+    Just existingValue+      | encodeDenseKey existingValue == encodedValue ->+          Just binding+      | otherwise ->+          Nothing+{-# INLINE bindVariableValue #-}
+ src-term/Moonlight/Core/Term/Database/Canonicalize.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | Canonicalisation of a term 'Database' under a key-renaming, plus entry+-- enumeration and tuple rehydration.+module Moonlight.Core.Term.Database.Canonicalize+  ( canonicalizeDatabase,+    canonicalizeDirtyRows,+    canonicalizeDirtyRowsInEditor,+  )+where++import Control.Monad.ST (ST)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Kind (Type)+import Data.Maybe (mapMaybe)+import Moonlight.Core.DenseKey (DenseKey (..))+import Moonlight.Core.Language (Language)+import Moonlight.Core.Term.Database+  ( Database,+    DatabaseEditor,+    DatabaseRow,+    DatabaseRowDelta (..),+    RowId,+    RowIdSet,+    TermCommitResult (..),+    TermCommand (..),+    rowChildren,+    rowResult,+    rowEntry,+    editorQueueCommands,+    editorSnapshot,+    commitTermCommands,+    mapRowKeys,+    normalizeTermCommands,+    runCommandTransaction,+  )+import Moonlight.Core.Term.Database.Projection+  ( dirtyRowsForKeysByOperatorId,+    operatorMapFromShapes,+    operatorRowsByOperatorId,+    operatorRowsForIdsByOperatorId,+  )+import Moonlight.Core.Term.Database.Types (operatorShapes)+import Prelude++-- | Rewrite every key in the database through the supplied renaming in a+-- single pass.+--+-- A congruence-closed renaming returns the rewritten database as 'Right'. Rows+-- that collide after rewriting return the residual congruence unions as+-- 'Left'; the partially rewritten database is deliberately not published.+-- Callers holding an open union-find should discharge those commands and+-- re-invoke with the updated renaming.+canonicalizeDatabase ::+  (DenseKey key, Language f) =>+  (key -> key) ->+  Database f key ->+  Either [TermCommand f key] (Database f key)+canonicalizeDatabase canonicalize db =+  case runCommandTransaction db (canonicalizeDirtyRowsInEditor (allKeys db) canonicalize) of+    (_result, [], canonicalDatabase) ->+      Right canonicalDatabase+    (_result, residualCommands, _partiallyCanonicalDatabase) ->+      Left residualCommands++canonicalizeDirtyRows ::+  (DenseKey key, Language f) =>+  IntSet ->+  (key -> key) ->+  Database f key ->+  (DatabaseRowDelta f, [TermCommand f key], Database f key)+canonicalizeDirtyRows dirtyKeys canonicalize db =+  canonicalizationResult plan (commitTermCommands (planCommands plan) db)+  where+    plan =+      canonicalizationPlan dirtyKeys canonicalize db++canonicalizeDirtyRowsInEditor ::+  (DenseKey key, Language f) =>+  IntSet ->+  (key -> key) ->+  DatabaseEditor s f key ->+  ST s (DatabaseRowDelta f, [TermCommand f key])+canonicalizeDirtyRowsInEditor dirtyKeys canonicalize editor = do+  snapshot <- editorSnapshot editor+  let plan =+        canonicalizationPlan dirtyKeys canonicalize snapshot+  commitResult <- editorQueueCommands (planCommands plan) editor+  let (delta, commands, _canonicalDb) =+        canonicalizationResult plan commitResult+  pure (delta, commands)++type CanonicalizationPlan :: (Type -> Type) -> Type -> Type+data CanonicalizationPlan f key = CanonicalizationPlan+  { deletedRowsByOperatorId :: !(IntMap [(RowId, DatabaseRow)]),+    planCommands :: ![TermCommand f key]+  }++canonicalizationPlan ::+  (DenseKey key, Language f) =>+  IntSet ->+  (key -> key) ->+  Database f key ->+  CanonicalizationPlan f key+canonicalizationPlan dirtyKeys canonicalize db =+  CanonicalizationPlan+    { deletedRowsByOperatorId = dirtyRows,+      planCommands =+        deleteRowCommands db dirtyRows+          <> insertRowCommands db candidateInsertedRows+    }+  where+    dirtyRows =+      rowsSelectedBy (dirtyRowsForKeysByOperatorId db dirtyKeys) db++    candidateInsertedRows =+      fmap (fmap (canonicalizeRow canonicalize . snd)) dirtyRows++canonicalizationResult ::+  (Ord key, Language f) =>+  CanonicalizationPlan f key ->+  TermCommitResult f key ->+  (DatabaseRowDelta f, [TermCommand f key], Database f key)+canonicalizationResult plan commitResult =+  (delta, commands, committedDatabase commitResult)+  where+    delta =+      DatabaseRowDelta+        { rowsDeleted =+            operatorMapFromShapes+              (committedDatabase commitResult)+              (deletedRowsByOperatorId plan),+          rowsInserted = insertedRows commitResult+        }++    commands =+      normalizeTermCommands (planCommands plan <> residualCommands commitResult)++deleteRowCommands ::+  forall f key.+  Database f key ->+  IntMap [(RowId, DatabaseRow)] ->+  [TermCommand f key]+deleteRowCommands database =+  IntMap.foldMapWithKey operatorDeleteCommands+  where+    operatorDeleteCommands ::+      Int ->+      [(RowId, DatabaseRow)] ->+      [TermCommand f key]+    operatorDeleteCommands operatorId rows =+      maybe+        []+        (\operator -> fmap (DeleteRow operator . fst) rows)+        (IntMap.lookup operatorId (operatorShapes database))++insertRowCommands ::+  forall key f.+  (DenseKey key, Language f) =>+  Database f key ->+  IntMap [DatabaseRow] ->+  [TermCommand f key]+insertRowCommands database =+  IntMap.foldMapWithKey operatorInsertCommands+  where+    operatorInsertCommands ::+      Int ->+      [DatabaseRow] ->+      [TermCommand f key]+    operatorInsertCommands operatorId rows =+      maybe+        []+        (\operator -> mapMaybe (fmap (uncurry InsertTerm) . rowEntry operator) rows)+        (IntMap.lookup operatorId (operatorShapes database))++rowsSelectedBy ::+  IntMap RowIdSet ->+  Database f key ->+  IntMap [(RowId, DatabaseRow)]+rowsSelectedBy selectedRows db =+  IntMap.mapWithKey+    (\operatorId rowIds -> operatorRowsForIdsByOperatorId operatorId rowIds db)+    selectedRows++canonicalizeRow :: DenseKey key => (key -> key) -> DatabaseRow -> DatabaseRow+canonicalizeRow canonicalize row =+  mapRowKeys canonicalizeKey row+  where+    canonicalizeKey =+      encodeDenseKey . canonicalize . decodeDenseKey++allKeys :: Database f key -> IntSet+allKeys db =+  IntSet.fromList+    [ key+      | rows <- IntMap.elems (operatorRowsByOperatorId db),+        (_rowId, row) <- rows,+        key <- rowResult row : rowChildren row+    ]
+ src-term/Moonlight/Core/Term/Database/Command.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE QuantifiedConstraints #-}++module Moonlight.Core.Term.Database.Command where++import Data.List qualified as List+import Data.Foldable (toList)+import Data.IntMap.Strict qualified as IntMap+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Set qualified as Set+import Moonlight.Core.DenseKey (DenseKey (..))+import Moonlight.Core.Language (Language)+import Moonlight.Core.Term.Database.Lookup+import Moonlight.Core.Term.Database.Projection+import Moonlight.Core.Term.Database.Table+import Moonlight.Core.Term.Database.Types+import Prelude++normalizeTermCommands ::+  (Ord key, Language f) =>+  [TermCommand f key] ->+  [TermCommand f key]+normalizeTermCommands =+  deduplicateSortedTermCommands+    . List.sortBy compareTermCommand+    . mapMaybe normalizeTermCommand++commitTermCommands ::+  forall key f.+  (DenseKey key, Language f) =>+  [TermCommand f key] ->+  Database f key ->+  TermCommitResult f key+commitTermCommands commands database =+  TermCommitResult+    { residualCommands =+        normalizeTermCommands (residualCommands insertCommit <> unionCommands),+      insertedRows =+        insertedRows insertCommit,+      committedDatabase =+        committedDatabase insertCommit+    }+  where+    (deletedDatabase, insertCommands, unionCommands) =+      foldl'+        collectTermCommand+        (database, [], [])+        (normalizeTermCommands commands)++    insertCommit =+      commitInsertCommands (reverse insertCommands) deletedDatabase++    collectTermCommand ::+      (Database f key, [(key, f key)], [TermCommand f key]) ->+      TermCommand f key ->+      (Database f key, [(key, f key)], [TermCommand f key])+    collectTermCommand (currentDatabase, inserts, unions) command =+      case command of+        DeleteRow operator rowId ->+          (deleteRow operator rowId currentDatabase, inserts, unions)+        InsertTerm resultValue tupleValue ->+          (currentDatabase, (resultValue, tupleValue) : inserts, unions)+        UnionResults {} ->+          (currentDatabase, inserts, command : unions)+{-# INLINE commitTermCommands #-}++commitInsertCommands ::+  forall key f.+  (DenseKey key, Language f) =>+  [(key, f key)] ->+  Database f key ->+  TermCommitResult f key+commitInsertCommands [] database =+  TermCommitResult+    { residualCommands = [],+      insertedRows = Map.empty,+      committedDatabase = database+    }+commitInsertCommands inserts database =+  TermCommitResult+    { residualCommands = residualCommands,+      insertedRows = operatorMapFromShapes insertedDatabase insertedRowsByOperatorId,+      committedDatabase = insertedDatabase+    }+  where+    (residualCommands, _tupleOwners) =+      foldl'+        collectInsertCommand+        ([], Map.empty)+        inserts++    (insertedRowsByOperatorId, insertedDatabase) =+      insertTuplesWithInsertedRows inserts database++    collectInsertCommand ::+      ([TermCommand f key], Map (f key) (Set.Set key)) ->+      (key, f key) ->+      ([TermCommand f key], Map (f key) (Set.Set key))+    collectInsertCommand (residualSoFar, tupleOwners) (resultValue, tupleValue) =+      ( Set.foldr (consUnionResult resultValue) residualSoFar owners,+        Map.insert tupleValue (Set.insert resultValue owners) tupleOwners+      )+      where+        owners =+          Map.findWithDefault+            (lookupTupleOwnerSet tupleValue database)+            tupleValue+            tupleOwners++    consUnionResult :: key -> key -> [TermCommand f key] -> [TermCommand f key]+    consUnionResult resultValue owner =+      (UnionResults resultValue owner :)++lookupTupleOwnerSet ::+  (DenseKey key, Language f) =>+  f key ->+  Database f key ->+  Set.Set key+lookupTupleOwnerSet tupleValue database+  | IntMap.null (operatorTables database) = Set.empty+  | otherwise =+      case lookupTupleAll tupleValue database of+        TupleMissing ->+          Set.empty+        TupleUnique owner ->+          Set.singleton owner+        TupleAmbiguous owners ->+          Set.fromList (toList owners)++normalizeTermCommand :: Ord key => TermCommand f key -> Maybe (TermCommand f key)+normalizeTermCommand command =+  case command of+    UnionResults left right+      | left == right ->+          Nothing+      | right < left ->+          Just (UnionResults right left)+      | otherwise ->+          Just command+    _ ->+      Just command+{-# INLINE normalizeTermCommand #-}++deduplicateSortedTermCommands ::+  forall key f.+  (Ord key, Language f) =>+  [TermCommand f key] ->+  [TermCommand f key]+deduplicateSortedTermCommands =+  foldr insertIfDifferent []+  where+    insertIfDifferent ::+      TermCommand f key ->+      [TermCommand f key] ->+      [TermCommand f key]+    insertIfDifferent command deduplicated@(nextCommand : _)+      | compareTermCommand command nextCommand == EQ =+          deduplicated+      | otherwise =+          command : deduplicated+    insertIfDifferent command [] =+      [command]+{-# INLINE deduplicateSortedTermCommands #-}++compareTermCommand ::+  (Ord key, Language f) =>+  TermCommand f key ->+  TermCommand f key ->+  Ordering+compareTermCommand left right =+  case left of+    DeleteRow leftOperator leftRow ->+      case right of+        DeleteRow rightOperator rightRow ->+          compare leftOperator rightOperator <> compare leftRow rightRow+        InsertTerm {} ->+          LT+        UnionResults {} ->+          LT+    InsertTerm leftResult leftTuple ->+      case right of+        DeleteRow {} ->+          GT+        InsertTerm rightResult rightTuple ->+          compare leftResult rightResult <> compare leftTuple rightTuple+        UnionResults {} ->+          LT+    UnionResults leftA leftB ->+      case right of+        DeleteRow {} ->+          GT+        InsertTerm {} ->+          GT+        UnionResults rightA rightB ->+          compare leftA rightA <> compare leftB rightB+{-# INLINE compareTermCommand #-}
+ src-term/Moonlight/Core/Term/Database/Encode.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE QuantifiedConstraints #-}++module Moonlight.Core.Term.Database.Encode where++import Data.Primitive.PrimArray (PrimArray)+import Data.Primitive.PrimArray qualified as PrimArray+import Moonlight.Core.DenseKey (DenseKey (..))+import Moonlight.Core.Term.Database.Types+import Prelude++encodedRow ::+  (DenseKey key, Foldable f) =>+  key ->+  f key ->+  DatabaseRow+encodedRow resultValue tupleValue =+  DatabaseRow+    { rowResult = encodeDenseKey resultValue,+      rowChildrenArray = encodedChildren tupleValue+    }+{-# INLINE encodedRow #-}++encodedChildren ::+  (DenseKey key, Foldable f) =>+  f key ->+  PrimArray Int+encodedChildren tupleValue =+  PrimArray.primArrayFromListN+    (length tupleValue)+    (foldr ((:) . encodeDenseKey) [] tupleValue)+{-# INLINE encodedChildren #-}
+ src-term/Moonlight/Core/Term/Database/FreeJoin.hs view
@@ -0,0 +1,444 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE QuantifiedConstraints #-}++module Moonlight.Core.Term.Database.FreeJoin where++import Control.Monad (foldM)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Maybe (catMaybes, isJust, isNothing, mapMaybe)+import Data.Set qualified as Set+import Moonlight.Core.DenseKey (DenseKey (..))+import Moonlight.Core.Language (Language)+import Moonlight.Core.Term.Database.Arrangement qualified as Arrangement+import Moonlight.Core.Term.Database.Atom+import Moonlight.Core.Term.Database.Index+import Moonlight.Core.Term.Database.OperatorTable+import Moonlight.Core.Term.Database.Table+import Moonlight.Core.Term.Database.Types+import Prelude++data ResolvedQueryAtom f key = ResolvedQueryAtom+  { resolvedQueryAtom :: !(QueryAtom f key),+    resolvedQueryAtomOperatorId :: !(Maybe Int)+  }++freeJoin ::+  (DenseKey key, Language f) =>+  FreeJoinPlan f key ->+  Database f key ->+  Either ArrangementValidationError ([QueryBinding key], Database f key)+freeJoin plan database =+  let resolvedAtoms =+        resolveFreeJoinAtoms database plan+      refreshedDatabase =+        ensurePlanDerivedIndexes resolvedAtoms database+   in case freeJoinStrategy plan of+        FreeJoinEmptyConjunction ->+          Right ([QueryBinding Map.empty], refreshedDatabase)+        FreeJoinExactAtomProbe ->+          exactAtomFreeJoin resolvedAtoms refreshedDatabase+        FreeJoinGenericIntersection ->+          genericFreeJoin resolvedAtoms refreshedDatabase+{-# INLINE freeJoin #-}++resolveFreeJoinAtoms ::+  Language f =>+  Database f key ->+  FreeJoinPlan f key ->+  [ResolvedQueryAtom f key]+resolveFreeJoinAtoms database =+  fmap (resolveQueryAtom database) . freeJoinAtoms+{-# INLINE resolveFreeJoinAtoms #-}++resolveQueryAtom ::+  Language f =>+  Database f key ->+  QueryAtom f key ->+  ResolvedQueryAtom f key+resolveQueryAtom database atom =+  ResolvedQueryAtom+    { resolvedQueryAtom = atom,+      resolvedQueryAtomOperatorId = operatorIdFor (atomOperator atom) database+    }+{-# INLINE resolveQueryAtom #-}++ensurePlanDerivedIndexes ::+  [ResolvedQueryAtom f key] ->+  Database f key ->+  Database f key+ensurePlanDerivedIndexes resolvedAtoms database =+  IntSet.foldl'+    (flip ensureOperatorDerivedIndexes)+    database+    (IntSet.fromList (mapMaybe resolvedQueryAtomOperatorId resolvedAtoms))+{-# INLINE ensurePlanDerivedIndexes #-}++freeJoinStrategy :: FreeJoinPlan f key -> FreeJoinStrategy+freeJoinStrategy plan =+  case freeJoinAtoms plan of+    [] ->+      FreeJoinEmptyConjunction+    [atom]+      | all termLiteralBound (atomChildren atom) ->+          FreeJoinExactAtomProbe+    _ ->+      FreeJoinGenericIntersection+{-# INLINE freeJoinStrategy #-}++termLiteralBound :: QueryTerm key -> Bool+termLiteralBound term =+  case term of+    QueryBound _key ->+      True+    QueryVariable _variable ->+      False+{-# INLINE termLiteralBound #-}++exactAtomFreeJoin ::+  (DenseKey key, Language f) =>+  [ResolvedQueryAtom f key] ->+  Database f key ->+  Either ArrangementValidationError ([QueryBinding key], Database f key)+exactAtomFreeJoin resolvedAtoms database =+  case resolvedAtoms of+    [resolvedAtom] -> do+      let emptyBinding :: QueryBinding key+          emptyBinding =+            QueryBinding Map.empty+          atom =+            resolvedQueryAtom resolvedAtom+      (candidateRows, arrangedDatabase) <-+        atomCandidateRows resolvedAtom emptyBinding database+      pure (mapMaybe (atomBindRow atom emptyBinding . snd) candidateRows, arrangedDatabase)+    _ ->+      genericFreeJoin resolvedAtoms database+{-# INLINE exactAtomFreeJoin #-}++genericFreeJoin ::+  (DenseKey key, Language f) =>+  [ResolvedQueryAtom f key] ->+  Database f key ->+  Either ArrangementValidationError ([QueryBinding key], Database f key)+genericFreeJoin resolvedAtoms database = do+  (joinedBindings, joinedDatabase) <-+    bindVariables+      resolvedAtoms+      (orderedVariables database resolvedAtoms)+      [QueryBinding Map.empty]+      database+  filterBindings resolvedAtoms joinedBindings joinedDatabase+{-# INLINE genericFreeJoin #-}++strictJoinTraverse ::+  (Database f key -> input -> Either err (Database f key, output)) ->+  Database f key ->+  [input] ->+  Either err (Database f key, [output])+strictJoinTraverse step database inputs =+  fmap+    (\(finalDatabase, reversedOutputs) -> (finalDatabase, reverse reversedOutputs))+    (foldM collect (database, []) inputs)+  where+    collect (!currentDatabase, !reversedOutputs) input = do+      (!nextDatabase, output) <- step currentDatabase input+      pure (nextDatabase, output : reversedOutputs)+{-# INLINE strictJoinTraverse #-}++bindVariables ::+  (DenseKey key, Language f) =>+  [ResolvedQueryAtom f key] ->+  [QueryVar] ->+  [QueryBinding key] ->+  Database f key ->+  Either ArrangementValidationError ([QueryBinding key], Database f key)+bindVariables resolvedAtoms variables bindings database =+  foldM bindVariable (bindings, database) variables+  where+    bindVariable (!currentBindings, !currentDatabase) variable = do+      (nextDatabase, extendedBindings) <-+        strictJoinTraverse+          (extendVariable resolvedAtoms variable)+          currentDatabase+          currentBindings+      let !nextBindings = concat extendedBindings+      pure (nextBindings, nextDatabase)+{-# INLINE bindVariables #-}++extendVariable ::+  (DenseKey key, Language f) =>+  [ResolvedQueryAtom f key] ->+  QueryVar ->+  Database f key ->+  QueryBinding key ->+  Either ArrangementValidationError (Database f key, [QueryBinding key])+extendVariable resolvedAtoms variable database binding = do+  (candidateKeys, candidateDatabase) <-+    variableCandidates resolvedAtoms variable binding database+  pure $+    case Map.lookup variable (queryBindingAssignments binding) of+      Just boundValue ->+        (candidateDatabase, [binding | IntSet.member (encodeDenseKey boundValue) candidateKeys])+      Nothing ->+        (candidateDatabase, mapMaybe (\key -> bindVariableValue variable key binding) (IntSet.toAscList candidateKeys))+{-# INLINE extendVariable #-}++variableCandidates ::+  (DenseKey key, Language f) =>+  [ResolvedQueryAtom f key] ->+  QueryVar ->+  QueryBinding key ->+  Database f key ->+  Either ArrangementValidationError (IntSet, Database f key)+variableCandidates resolvedAtoms variable binding database = do+  (arrangedDatabase, candidateSets) <-+    strictJoinTraverse+      (atomVariableCandidates variable binding)+      database+      (atomsForVariable variable resolvedAtoms)+  pure (intersectCandidateSets candidateSets, arrangedDatabase)+{-# INLINE variableCandidates #-}++atomVariableCandidates ::+  (DenseKey key, Language f) =>+  QueryVar ->+  QueryBinding key ->+  Database f key ->+  ResolvedQueryAtom f key ->+  Either ArrangementValidationError (Database f key, IntSet)+atomVariableCandidates variable binding database resolvedAtom = do+  (candidateRows, arrangedDatabase) <-+    atomCandidateRows resolvedAtom binding database+  pure+    ( arrangedDatabase,+      IntSet.fromList+        [ encodeDenseKey variableValue+          | (_rowId, row) <- candidateRows,+            Just nextBinding <- [atomBindRow (resolvedQueryAtom resolvedAtom) binding row],+            Just variableValue <- [Map.lookup variable (queryBindingAssignments nextBinding)]+        ]+    )+{-# INLINE atomVariableCandidates #-}++intersectCandidateSets :: [IntSet] -> IntSet+intersectCandidateSets candidateSets =+  case candidateSets of+    [] ->+      IntSet.empty+    firstSet : restSets ->+      foldl' IntSet.intersection firstSet restSets+{-# INLINE intersectCandidateSets #-}++filterBindings ::+  (DenseKey key, Language f) =>+  [ResolvedQueryAtom f key] ->+  [QueryBinding key] ->+  Database f key ->+  Either ArrangementValidationError ([QueryBinding key], Database f key)+filterBindings resolvedAtoms bindings database = do+  (checkedDatabase, checkedBindings) <-+    strictJoinTraverse (filterBinding resolvedAtoms) database bindings+  pure (catMaybes checkedBindings, checkedDatabase)+{-# INLINE filterBindings #-}++filterBinding ::+  (DenseKey key, Language f) =>+  [ResolvedQueryAtom f key] ->+  Database f key ->+  QueryBinding key ->+  Either ArrangementValidationError (Database f key, Maybe (QueryBinding key))+filterBinding resolvedAtoms database binding = do+  (checkedDatabase, satisfied) <-+    strictJoinTraverse+      (atomSatisfied binding)+      database+      resolvedAtoms+  pure (checkedDatabase, if and satisfied then Just binding else Nothing)+{-# INLINE filterBinding #-}++atomSatisfied ::+  (DenseKey key, Language f) =>+  QueryBinding key ->+  Database f key ->+  ResolvedQueryAtom f key ->+  Either ArrangementValidationError (Database f key, Bool)+atomSatisfied binding database resolvedAtom = do+  (candidateRows, arrangedDatabase) <-+    atomCandidateRows resolvedAtom binding database+  pure+    ( arrangedDatabase,+      any (isJust . atomBindRow (resolvedQueryAtom resolvedAtom) binding . snd) candidateRows+    )+{-# INLINE atomSatisfied #-}++orderedVariables ::+  Database f key ->+  [ResolvedQueryAtom f key] ->+  [QueryVar]+orderedVariables database resolvedAtoms =+  List.sortOn+    (variableCost database resolvedAtoms)+    (Set.toList (planVariables resolvedAtoms))+{-# INLINE orderedVariables #-}++planVariables :: [ResolvedQueryAtom f key] -> Set.Set QueryVar+planVariables =+  foldMap (atomVariables . resolvedQueryAtom)+{-# INLINE planVariables #-}++atomVariables :: QueryAtom f key -> Set.Set QueryVar+atomVariables =+  foldMap termVariables . atomTerms+{-# INLINE atomVariables #-}++termVariables :: QueryTerm key -> Set.Set QueryVar+termVariables term =+  case term of+    QueryBound _ ->+      Set.empty+    QueryVariable variable ->+      Set.singleton variable+{-# INLINE termVariables #-}++atomsForVariable :: QueryVar -> [ResolvedQueryAtom f key] -> [ResolvedQueryAtom f key]+atomsForVariable variable =+  filter (atomMentionsVariable variable . resolvedQueryAtom)+{-# INLINE atomsForVariable #-}++atomMentionsVariable :: QueryVar -> QueryAtom f key -> Bool+atomMentionsVariable variable =+  Set.member variable . atomVariables+{-# INLINE atomMentionsVariable #-}++variableCost ::+  Database f key ->+  [ResolvedQueryAtom f key] ->+  QueryVar ->+  (Int, Int, QueryVar)+variableCost database resolvedAtoms variable =+  ( minimumCandidateDistinct variableDistincts,+    negate (length variableDistincts),+    variable+  )+  where+    variableDistincts =+      [ distinct+        | resolvedAtom <- atomsForVariable variable resolvedAtoms,+          column <- atomVariableColumns variable (resolvedQueryAtom resolvedAtom),+          Just distinct <- [atomColumnDistinct database resolvedAtom column]+      ]+{-# INLINE variableCost #-}++minimumCandidateDistinct :: [Int] -> Int+minimumCandidateDistinct values =+  case values of+    [] ->+      maxBound+    firstValue : restValues ->+      foldl' min firstValue restValues+{-# INLINE minimumCandidateDistinct #-}++atomVariableColumns :: QueryVar -> QueryAtom f key -> [Column]+atomVariableColumns variable atom =+  [ column+    | (column, QueryVariable columnVariable) <- zip (atomColumns atom) (atomTerms atom),+      columnVariable == variable+  ]+{-# INLINE atomVariableColumns #-}++atomColumnDistinct :: Database f key -> ResolvedQueryAtom f key -> Column -> Maybe Int+atomColumnDistinct database resolvedAtom column =+  resolvedQueryAtomOperatorId resolvedAtom+    >>= \operatorId -> IntMap.lookup operatorId (operatorTables database)+    >>= \table -> Just (Arrangement.distinctColumnValueCount table column)+{-# INLINE atomColumnDistinct #-}++atomCandidateRows ::+  (DenseKey key, Language f) =>+  ResolvedQueryAtom f key ->+  QueryBinding key ->+  Database f key ->+  Either ArrangementValidationError ([(RowId, DatabaseRow)], Database f key)+atomCandidateRows resolvedAtom binding database =+  case resolvedQueryAtomOperatorId resolvedAtom >>= lookupOperatorTable of+    Just table+      | Just rowIds <- atomIndexedCandidateRows atom binding table ->+          Right (rowsForIds table rowIds, database)+    _ -> do+      (arrangementKey, arrangementPrefix) <-+        atomArrangementPrefix atom binding+      Arrangement.arrangementRowsForResolvedOperator+        (resolvedQueryAtomOperatorId resolvedAtom)+        (atomOperator atom)+        arrangementKey+        arrangementPrefix+        database+  where+    atom =+      resolvedQueryAtom resolvedAtom+    lookupOperatorTable operatorId =+      IntMap.lookup operatorId (operatorTables database)+{-# INLINE atomCandidateRows #-}++atomIndexedCandidateRows ::+  DenseKey key =>+  QueryAtom f key ->+  QueryBinding key ->+  OperatorTable f ->+  Maybe RowIdSet+atomIndexedCandidateRows atom binding table =+  chooseIndexedCandidateRows exactRows resultRows+  where+    exactRows =+      fmap+        (\childKeys -> lookupExactIndex childKeys (derivedExactIndex table))+        (traverse (termBoundValue binding) (atomChildren atom))++    resultRows =+      fmap+        (\resultKey -> lookupResultIndex resultKey (derivedResultIndex table))+        (termBoundValue binding (atomResult atom))+{-# INLINE atomIndexedCandidateRows #-}++chooseIndexedCandidateRows :: Maybe RowIdSet -> Maybe RowIdSet -> Maybe RowIdSet+chooseIndexedCandidateRows exactRows resultRows =+  case (exactRows, resultRows) of+    (Just leftRows, Just rightRows)+      | rowIdSetSize leftRows <= rowIdSetSize rightRows ->+          Just leftRows+      | otherwise ->+          Just rightRows+    (Just rows, Nothing) ->+      Just rows+    (Nothing, Just rows) ->+      Just rows+    (Nothing, Nothing) ->+      Nothing+{-# INLINE chooseIndexedCandidateRows #-}++atomArrangementPrefix ::+  (DenseKey key, Foldable f) =>+  QueryAtom f key ->+  QueryBinding key ->+  Either ArrangementValidationError (ArrangementKey, ArrangementPrefix)+atomArrangementPrefix atom binding = do+  arrangementKey <-+    arrangementKeyForOperator+      (atomOperator atom)+      (fmap fst boundColumns <> unboundColumns)+  arrangementPrefix <-+    arrangementPrefixForKey arrangementKey (fmap snd boundColumns)+  pure (arrangementKey, arrangementPrefix)+  where+    columnTerms =+      zip (atomColumns atom) (atomTerms atom)++    boundColumns =+      mapMaybe (boundColumn binding) columnTerms++    unboundColumns =+      fmap fst (filter (isNothing . termBoundValue binding . snd) columnTerms)+{-# INLINE atomArrangementPrefix #-}
+ src-term/Moonlight/Core/Term/Database/Index.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE BangPatterns #-}++module Moonlight.Core.Term.Database.Index 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 (Map)+import Data.Map.Strict qualified as Map+import Data.Primitive.PrimArray (PrimArray)+import Data.Primitive.PrimArray qualified as PrimArray+import Data.Primitive.SmallArray qualified as SmallArray+import Data.Traversable (mapAccumL)+import Moonlight.Core.Term.Database.Types+import Prelude++derivedResultIndex :: OperatorTable f -> ResultIndex+derivedResultIndex =+  resultIx+{-# INLINE derivedResultIndex #-}++derivedChildColumnValueIndex :: OperatorTable f -> ChildColumnValueIndex+derivedChildColumnValueIndex =+  childColumnIx+{-# INLINE derivedChildColumnValueIndex #-}++derivedExactIndex :: OperatorTable f -> ExactIndex+derivedExactIndex =+  exactIx+{-# INLINE derivedExactIndex #-}++derivedChildUserIndex :: OperatorTable f -> ChildUserIndex+derivedChildUserIndex =+  childUserIx+{-# INLINE derivedChildUserIndex #-}++emptyExactIndex :: Int -> ExactIndex+emptyExactIndex =+  emptyChildTupleIndex++emptyExactResultIndex :: Int -> ExactResultIndex+emptyExactResultIndex =+  emptyChildTupleIndex++emptyChildTupleIndex :: Int -> ChildTupleIndex+emptyChildTupleIndex arity =+  case arity of+    0 -> NullaryChildTupleIndex IntSet.empty+    1 -> UnaryChildTupleIndex IntMap.empty+    2 -> BinaryChildTupleIndex IntMap.empty+    _ -> NaryChildTupleIndex Map.empty++emptyResultIndex :: ResultIndex+emptyResultIndex =+  IntMap.empty++emptyChildColumnValueIndex :: Int -> ChildColumnValueIndex+emptyChildColumnValueIndex arity =+  case arity of+    0 -> NullaryChildColumnValueIndex+    1 -> UnaryChildColumnValueIndex IntMap.empty+    2 -> BinaryChildColumnValueIndex IntMap.empty IntMap.empty+    _ -> NaryChildColumnValueIndex (SmallArray.smallArrayFromList (replicate arity IntMap.empty))+{-# INLINE emptyChildColumnValueIndex #-}++emptyChildUserIndex :: ChildUserIndex+emptyChildUserIndex =+  IntMap.empty++lookupExactIndex :: [Int] -> ExactIndex -> RowIdSet+lookupExactIndex children =+  RowIdSet . lookupChildTupleProbe children+{-# INLINE lookupExactIndex #-}++lookupExactIndexArray :: PrimArray Int -> ExactIndex -> RowIdSet+lookupExactIndexArray children =+  RowIdSet . lookupChildTupleIndex children+{-# INLINE lookupExactIndexArray #-}++lookupExactResultIndex :: PrimArray Int -> ExactResultIndex -> IntSet+lookupExactResultIndex =+  lookupChildTupleIndex+{-# INLINE lookupExactResultIndex #-}++lookupChildTupleProbe :: [Int] -> ChildTupleIndex -> IntSet+lookupChildTupleProbe children childTupleIndex =+  case childTupleIndex of+    NullaryChildTupleIndex keys ->+      case children of+        [] -> keys+        _nonNullaryChildren -> IntSet.empty+    UnaryChildTupleIndex byChild ->+      case children of+        [child] -> IntMap.findWithDefault IntSet.empty child byChild+        _nonUnaryChildren -> IntSet.empty+    BinaryChildTupleIndex byLeftChild ->+      case children of+        [leftChild, rightChild] ->+          maybe IntSet.empty (IntMap.findWithDefault IntSet.empty rightChild) (IntMap.lookup leftChild byLeftChild)+        _nonBinaryChildren -> IntSet.empty+    NaryChildTupleIndex byChildren ->+      Map.findWithDefault IntSet.empty (ProbeChildTupleKey children) byChildren+{-# INLINE lookupChildTupleProbe #-}++lookupChildTupleIndex :: PrimArray Int -> ChildTupleIndex -> IntSet+lookupChildTupleIndex children childTupleIndex =+  case childTupleIndex of+    NullaryChildTupleIndex keys ->+      if PrimArray.sizeofPrimArray children == 0+        then keys+        else IntSet.empty+    UnaryChildTupleIndex byChild ->+      if PrimArray.sizeofPrimArray children == 1+        then IntMap.findWithDefault IntSet.empty (PrimArray.indexPrimArray children 0) byChild+        else IntSet.empty+    BinaryChildTupleIndex byLeftChild ->+      if PrimArray.sizeofPrimArray children == 2+        then+          maybe+            IntSet.empty+            (IntMap.findWithDefault IntSet.empty (PrimArray.indexPrimArray children 1))+            (IntMap.lookup (PrimArray.indexPrimArray children 0) byLeftChild)+        else IntSet.empty+    NaryChildTupleIndex byChildren ->+      Map.findWithDefault IntSet.empty (StoredChildTupleKey children) byChildren+{-# INLINE lookupChildTupleIndex #-}++lookupResultIndex :: Int -> ResultIndex -> RowIdSet+lookupResultIndex resultKey =+  RowIdSet . IntMap.findWithDefault IntSet.empty resultKey+{-# INLINE lookupResultIndex #-}++intMapDependentsOfMany :: [Int] -> IntMap IntSet -> IntSet+intMapDependentsOfMany keys indexValue =+  foldMap (\key -> IntMap.findWithDefault IntSet.empty key indexValue) keys+{-# INLINE intMapDependentsOfMany #-}++insertExactIndex :: Int -> PrimArray Int -> ExactIndex -> ExactIndex+insertExactIndex =+  insertChildTupleIndex+{-# INLINE insertExactIndex #-}++insertExactResultIndex :: Int -> PrimArray Int -> ExactResultIndex -> ExactResultIndex+insertExactResultIndex =+  insertChildTupleIndex+{-# INLINE insertExactResultIndex #-}++insertChildTupleIndex :: Int -> PrimArray Int -> ChildTupleIndex -> ChildTupleIndex+insertChildTupleIndex dependent children childTupleIndex =+  case childTupleIndex of+    NullaryChildTupleIndex keys ->+      if PrimArray.sizeofPrimArray children == 0+        then NullaryChildTupleIndex (IntSet.insert dependent keys)+        else childTupleIndex+    UnaryChildTupleIndex byChild ->+      if PrimArray.sizeofPrimArray children == 1+        then UnaryChildTupleIndex (insertIntSetAtKey (PrimArray.indexPrimArray children 0) dependent byChild)+        else childTupleIndex+    BinaryChildTupleIndex byLeftChild ->+      if PrimArray.sizeofPrimArray children == 2+        then+          BinaryChildTupleIndex $+            IntMap.insertWith+              (IntMap.unionWith IntSet.union)+              (PrimArray.indexPrimArray children 0)+              (IntMap.singleton (PrimArray.indexPrimArray children 1) (IntSet.singleton dependent))+              byLeftChild+        else childTupleIndex+    NaryChildTupleIndex byChildren ->+      NaryChildTupleIndex $+        Map.insertWith+          IntSet.union+          (StoredChildTupleKey children)+          (IntSet.singleton dependent)+          byChildren+{-# INLINE insertChildTupleIndex #-}++insertResultIndex :: Int -> Int -> ResultIndex -> ResultIndex+insertResultIndex rowKey resultKey =+  insertIntSetAtKey resultKey rowKey+{-# INLINE insertResultIndex #-}++insertChildUserIndex :: Int -> Int -> ChildUserIndex -> ChildUserIndex+insertChildUserIndex rowKey childKey =+  insertIntSetAtKey childKey rowKey+{-# INLINE insertChildUserIndex #-}++deleteExactIndex :: Int -> PrimArray Int -> ExactIndex -> ExactIndex+deleteExactIndex =+  deleteChildTupleIndex+{-# INLINE deleteExactIndex #-}++deleteExactResultIndex :: Int -> PrimArray Int -> ExactResultIndex -> ExactResultIndex+deleteExactResultIndex =+  deleteChildTupleIndex+{-# INLINE deleteExactResultIndex #-}++deleteResultIndex :: Int -> Int -> ResultIndex -> ResultIndex+deleteResultIndex rowKey resultKey =+  removeIntSetAtIntKey resultKey rowKey+{-# INLINE deleteResultIndex #-}++deleteChildUserIndex :: Int -> Int -> ChildUserIndex -> ChildUserIndex+deleteChildUserIndex rowKey childKey =+  removeIntSetAtIntKey childKey rowKey+{-# INLINE deleteChildUserIndex #-}++deleteChildTupleIndex :: Int -> PrimArray Int -> ChildTupleIndex -> ChildTupleIndex+deleteChildTupleIndex dependent children childTupleIndex =+  case childTupleIndex of+    NullaryChildTupleIndex keys ->+      if PrimArray.sizeofPrimArray children == 0+        then NullaryChildTupleIndex (IntSet.delete dependent keys)+        else childTupleIndex+    UnaryChildTupleIndex byChild ->+      if PrimArray.sizeofPrimArray children == 1+        then UnaryChildTupleIndex (removeIntSetAtIntKey (PrimArray.indexPrimArray children 0) dependent byChild)+        else childTupleIndex+    BinaryChildTupleIndex byLeftChild ->+      if PrimArray.sizeofPrimArray children == 2+        then+          BinaryChildTupleIndex $+            IntMap.update+              (nonEmptyIntMap . removeIntSetAtIntKey (PrimArray.indexPrimArray children 1) dependent)+              (PrimArray.indexPrimArray children 0)+              byLeftChild+        else childTupleIndex+    NaryChildTupleIndex byChildren ->+      NaryChildTupleIndex (removeIntSetAtMapKey (StoredChildTupleKey children) dependent byChildren)+{-# INLINE deleteChildTupleIndex #-}++insertIntSetAtKey :: Int -> Int -> IntMap IntSet -> IntMap IntSet+insertIntSetAtKey key dependent =+  IntMap.insertWith IntSet.union key (IntSet.singleton dependent)+{-# INLINE insertIntSetAtKey #-}++removeIntSetAtIntKey :: Int -> Int -> IntMap IntSet -> IntMap IntSet+removeIntSetAtIntKey key dependent =+  IntMap.update (nonEmptyIntSet . IntSet.delete dependent) key+{-# INLINE removeIntSetAtIntKey #-}++removeIntSetAtMapKey :: Ord key => key -> Int -> Map key IntSet -> Map key IntSet+removeIntSetAtMapKey key dependent =+  Map.update (nonEmptyIntSet . IntSet.delete dependent) key+{-# INLINE removeIntSetAtMapKey #-}++nonEmptyIntSet :: IntSet -> Maybe IntSet+nonEmptyIntSet values+  | IntSet.null values = Nothing+  | otherwise = Just values+{-# INLINE nonEmptyIntSet #-}++nonEmptyIntMap :: IntMap value -> Maybe (IntMap value)+nonEmptyIntMap values+  | IntMap.null values = Nothing+  | otherwise = Just values+{-# INLINE nonEmptyIntMap #-}++insertChildColumnValueIndex :: Int -> PrimArray Int -> ChildColumnValueIndex -> ChildColumnValueIndex+insertChildColumnValueIndex =+  alterChildColumnValueIndex insertIntSetAtKey+{-# INLINE insertChildColumnValueIndex #-}++deleteChildColumnValueIndex :: Int -> PrimArray Int -> ChildColumnValueIndex -> ChildColumnValueIndex+deleteChildColumnValueIndex =+  alterChildColumnValueIndex removeIntSetAtIntKey+{-# INLINE deleteChildColumnValueIndex #-}++alterChildColumnValueIndex ::+  (Int -> Int -> IntMap IntSet -> IntMap IntSet) ->+  Int ->+  PrimArray Int ->+  ChildColumnValueIndex ->+  ChildColumnValueIndex+alterChildColumnValueIndex alterValueRows rowKey children childColumnIndexes =+  case childColumnIndexes of+    NullaryChildColumnValueIndex ->+      childColumnIndexes+    UnaryChildColumnValueIndex values ->+      if PrimArray.sizeofPrimArray children == 1+        then UnaryChildColumnValueIndex (alterValueRows (PrimArray.indexPrimArray children 0) rowKey values)+        else childColumnIndexes+    BinaryChildColumnValueIndex leftValues rightValues ->+      if PrimArray.sizeofPrimArray children == 2+        then+          BinaryChildColumnValueIndex+            (alterValueRows (PrimArray.indexPrimArray children 0) rowKey leftValues)+            (alterValueRows (PrimArray.indexPrimArray children 1) rowKey rightValues)+        else childColumnIndexes+    NaryChildColumnValueIndex values ->+      if PrimArray.sizeofPrimArray children == SmallArray.sizeofSmallArray values+        then NaryChildColumnValueIndex (snd (mapAccumL alterColumnAt 0 values))+        else childColumnIndexes+  where+    alterColumnAt !childIndex childValueRows =+      ( childIndex + 1,+        alterValueRows+          (PrimArray.indexPrimArray children childIndex)+          rowKey+          childValueRows+      )+{-# INLINE alterChildColumnValueIndex #-}
+ src-term/Moonlight/Core/Term/Database/Lookup.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE QuantifiedConstraints #-}++module Moonlight.Core.Term.Database.Lookup where++import Data.IntMap.Strict qualified as IntMap+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Traversable (mapAccumL)+import Moonlight.Core.DenseKey (DenseKey (..))+import Moonlight.Core.Language (Language)+import Moonlight.Core.Term.Database.Encode+import Moonlight.Core.Term.Database.OperatorTable+import Moonlight.Core.Term.Database.Projection+import Moonlight.Core.Term.Database.Types+import Prelude++rowEntry ::+  (DenseKey key, Traversable f) =>+  Operator f ->+  DatabaseRow ->+  Maybe (key, f key)+rowEntry (Operator template) row =+  fmap+    (\filledTemplate -> (decodeDenseKey (rowResult row), filledTemplate))+    (rehydrateChildren template (rowChildren row))++databaseEntries ::+  (DenseKey key, Traversable f) =>+  Database f key ->+  [(key, f key)]+databaseEntries db =+  foldOperatorTables+    (\operator -> entriesForOperatorRows operator . operatorTableRows)+    db++entriesForResultKey ::+  (DenseKey key, Language f) =>+  key ->+  Database f key ->+  [(key, f key)]+entriesForResultKey resultValue db =+  foldOperatorTables (entriesForOperatorResultKey resultValue) db++foldOperatorTables ::+  Monoid result =>+  (Operator f -> OperatorTable f -> result) ->+  Database f key ->+  result+foldOperatorTables collectOperatorTable database =+  Map.foldMapWithKey collectInternedOperator (operatorIds database)+  where+    collectInternedOperator operator operatorId =+      maybe+        mempty+        (collectOperatorTable operator)+        (IntMap.lookup operatorId (operatorTables database))+{-# INLINE foldOperatorTables #-}++entriesForOperatorRows ::+  (DenseKey key, Traversable f) =>+  Operator f ->+  [(rowId, DatabaseRow)] ->+  [(key, f key)]+entriesForOperatorRows operator =+  mapMaybe (rowEntry operator . snd)++entriesForOperatorResultKey ::+  (DenseKey key, Language f) =>+  key ->+  Operator f ->+  OperatorTable f ->+  [(key, f key)]+entriesForOperatorResultKey resultValue (Operator template) table =+  fmap+    (\filledTemplate -> (resultValue, filledTemplate))+    (mapMaybe (rehydrateChildren template . rowChildren . snd) rows)+  where+    rows =+      operatorTableRowsForResultKey (encodeDenseKey resultValue) table++rehydrateTuple ::+  (DenseKey key, Traversable f) =>+  Operator f ->+  [Int] ->+  Maybe (key, f key)+rehydrateTuple (Operator template) (resultKey : childKeys) =+  fmap+    (\children -> (decodeDenseKey resultKey, children))+    (rehydrateChildren template childKeys)+rehydrateTuple _ [] =+  Nothing++rehydrateChildren ::+  (DenseKey key, Traversable f) =>+  f () ->+  [Int] ->+  Maybe (f key)+rehydrateChildren template childKeys =+  case mapAccumL step (Right childKeys) template of+    (Right [], filled) -> sequenceA filled+    _ -> Nothing+  where+    step ::+      DenseKey key =>+      Either () [Int] ->+      () ->+      (Either () [Int], Maybe key)+    step (Left ()) () =+      (Left (), Nothing)+    step (Right []) () =+      (Left (), Nothing)+    step (Right (keyValue : restKeys)) () =+      (Right restKeys, Just (decodeDenseKey keyValue))++lookupTupleAll ::+  (DenseKey key, Language f) =>+  f key ->+  Database f key ->+  TupleLookup key+lookupTupleAll tupleValue database =+  maybe+    TupleMissing+    (tupleLookupFromResultKeys . lookupChildResultKeys childKeys)+    (operatorTableFor (extractOperator tupleValue) database)+  where+    childKeys = encodedChildren tupleValue++lookupTupleUnique ::+  (DenseKey key, Language f) =>+  f key ->+  Database f key ->+  Either (NonEmpty key) (Maybe key)+lookupTupleUnique tupleValue database =+  case lookupTupleAll tupleValue database of+    TupleMissing -> Right Nothing+    TupleUnique key -> Right (Just key)+    TupleAmbiguous keys -> Left keys++lookupLeastTuple ::+  (DenseKey key, Language f) =>+  f key ->+  Database f key ->+  Maybe key+lookupLeastTuple tupleValue database =+  maybe+    Nothing+    (tupleLeastFromResultKeys . lookupChildResultKeys childKeys)+    (operatorTableFor (extractOperator tupleValue) database)+  where+    childKeys = encodedChildren tupleValue++tupleLookupFromResultKeys :: DenseKey key => IntSet -> TupleLookup key+tupleLookupFromResultKeys encodedResultKeys =+  case fmap decodeDenseKey (IntSet.toAscList encodedResultKeys) of+    [] -> TupleMissing+    [key] -> TupleUnique key+    key : otherKeys -> TupleAmbiguous (key :| otherKeys)++tupleLeastFromResultKeys :: DenseKey key => IntSet -> Maybe key+tupleLeastFromResultKeys =+  fmap decodeDenseKey . IntSet.lookupMin+{-# INLINE tupleLeastFromResultKeys #-}
+ src-term/Moonlight/Core/Term/Database/OperatorTable.hs view
@@ -0,0 +1,571 @@+module Moonlight.Core.Term.Database.OperatorTable where++import Data.Foldable (toList)+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Kind (Type)+import Data.Maybe (mapMaybe)+import Data.Primitive.PrimArray (PrimArray)+import Data.Primitive.PrimArray qualified as PrimArray+import Data.Primitive.SmallArray qualified as SmallArray+import Data.Sequence qualified as Seq+import Moonlight.Core.Term.Database.Index+import Moonlight.Core.Term.Database.Types+import Prelude++operatorRowChunkCapacity :: Int+-- One sealed column occupies 4 KiB on the measured 64-bit target. The+-- unsealed suffix therefore remains strictly bounded without forcing small+-- batches through column transposition.+operatorRowChunkCapacity =+  512++emptyOperatorRowStore :: OperatorRowStore+emptyOperatorRowStore =+  OperatorRowStore+    { sealedRowChunks = Seq.empty,+      pendingStoredRows = Seq.empty,+      tombstonedRowIds = IntSet.empty+    }++emptyOperatorTable :: Foldable f => f () -> OperatorTable f+emptyOperatorTable shape =+  OperatorTable+    { opShape = shape,+      opArity = arity,+      rowStore = emptyOperatorRowStore,+      nextRowId = 0,+      derivedIndexWatermark = 0,+      resultIx = emptyResultIndex,+      childColumnIx = emptyChildColumnValueIndex arity,+      exactIx = emptyExactIndex arity,+      exactResultIx = emptyExactResultIndex arity,+      childUserIx = emptyChildUserIndex+    }+  where+    arity = length (toList shape)+{-# INLINE emptyOperatorTable #-}++operatorTableFromRows :: Foldable f => f () -> [DatabaseRow] -> OperatorTable f+operatorTableFromRows shape rows =+  OperatorTable+    { opShape = shape,+      opArity = arity,+      rowStore = operatorRowStoreFromRows arity rows,+      nextRowId = rowCount,+      derivedIndexWatermark = rowCount,+      resultIx =+        foldl'+          (\resultIndex (rowKey, row) ->+             insertResultIndex rowKey (rowResult row) resultIndex)+          emptyResultIndex+          indexedRows,+      childColumnIx =+        foldl'+          (\childColumnIndexes (rowKey, row) ->+             insertChildColumnValueIndex rowKey (rowChildrenArray row) childColumnIndexes)+          (emptyChildColumnValueIndex arity)+          indexedRows,+      exactIx =+        foldl'+          (\exactIndex (rowKey, row) ->+             insertExactIndex rowKey (rowChildrenArray row) exactIndex)+          (emptyExactIndex arity)+          indexedRows,+      exactResultIx =+        foldl'+          (\exactResultIndex (_rowKey, row) ->+             insertExactResultIndex (rowResult row) (rowChildrenArray row) exactResultIndex)+          (emptyExactResultIndex arity)+          indexedRows,+      childUserIx =+        foldl'+          (\childUsers (rowKey, row) ->+             PrimArray.foldrPrimArray+               (\childKey -> insertChildUserIndex rowKey childKey)+               childUsers+               (rowChildrenArray row))+          emptyChildUserIndex+          indexedRows+    }+  where+    arity = length (toList shape)+    rowCount = length rows+    indexedRows = zip (ascendingRowKeys rowCount) rows+{-# INLINE operatorTableFromRows #-}++operatorRowStoreFromRows :: Int -> [DatabaseRow] -> OperatorRowStore+operatorRowStoreFromRows arity =+  foldl' (\store row -> appendStoredRow arity row store) emptyOperatorRowStore++appendStoredRow :: Int -> DatabaseRow -> OperatorRowStore -> OperatorRowStore+appendStoredRow arity row store+  | Seq.length appendedPendingRows == operatorRowChunkCapacity =+      store+        { sealedRowChunks =+            sealedRowChunks store Seq.|> operatorRowChunkFromRows arity appendedPendingRows,+          pendingStoredRows = Seq.empty+        }+  | otherwise =+      store+        { pendingStoredRows = appendedPendingRows+        }+  where+    appendedPendingRows =+      pendingStoredRows store Seq.|> row+{-# INLINE appendStoredRow #-}++operatorRowChunkFromRows :: Int -> Seq.Seq DatabaseRow -> OperatorRowChunk+operatorRowChunkFromRows arity rows =+  OperatorRowChunk+    { chunkResults =+        PrimArray.primArrayFromListN rowCount (fmap rowResult rowList),+      chunkChildren =+        SmallArray.smallArrayFromList+          (fmap childColumn (ascendingRowKeys arity))+    }+  where+    rowList =+      toList rows+    rowCount =+      length rowList+    childColumn childIndex =+      PrimArray.primArrayFromListN (length childValues) childValues+      where+        childValues =+          mapMaybe (childValueAt childIndex . rowChildrenArray) rowList+{-# INLINE operatorRowChunkFromRows #-}++tableLiveRows :: OperatorTable f -> RowIdSet+tableLiveRows table =+  RowIdSet+    ( IntSet.difference+        (IntSet.fromDistinctAscList (ascendingRowKeys (nextRowId table)))+        (tombstonedRowIds (rowStore table))+    )+{-# INLINE tableLiveRows #-}++tableLiveRowCount :: OperatorTable f -> Int+tableLiveRowCount table =+  nextRowId table - IntSet.size (tombstonedRowIds (rowStore table))+{-# INLINE tableLiveRowCount #-}++applyOperatorTableRowEdit :: OperatorTableRowEdit -> OperatorTable f -> OperatorTable f+applyOperatorTableRowEdit edit table =+  case edit of+    InsertOperatorTableRow row ->+      table+        { exactResultIx =+            insertExactResultIndex (rowResult row) (rowChildrenArray row) (exactResultIx table)+        }+    DeleteOperatorTableRow rowKey row ->+      let tableWithoutEagerRow =+            table+              { exactResultIx =+                  deleteExactResultIndex (rowResult row) (rowChildrenArray row) (exactResultIx table)+              }+       in if rowKey < derivedIndexWatermark table+            then deleteRowFromDerivedIndexes rowKey row tableWithoutEagerRow+            -- Rows at or above the watermark were never derived-indexed, and+            -- refresh reads the post-delete live row store, so it cannot+            -- restore them.+            else tableWithoutEagerRow+{-# INLINE applyOperatorTableRowEdit #-}++insertRowIntoDerivedIndexes :: Int -> DatabaseRow -> OperatorTable f -> OperatorTable f+insertRowIntoDerivedIndexes rowKey row table =+  table+    { resultIx =+        insertResultIndex rowKey (rowResult row) (resultIx table),+      childColumnIx =+        insertChildColumnValueIndex rowKey (rowChildrenArray row) (childColumnIx table),+      exactIx =+        insertExactIndex rowKey (rowChildrenArray row) (exactIx table),+      childUserIx =+        PrimArray.foldrPrimArray+          (insertChildUserIndex rowKey)+          (childUserIx table)+          (rowChildrenArray row)+    }+{-# INLINE insertRowIntoDerivedIndexes #-}++deleteRowFromDerivedIndexes :: Int -> DatabaseRow -> OperatorTable f -> OperatorTable f+deleteRowFromDerivedIndexes rowKey row table =+  table+    { resultIx =+        deleteResultIndex rowKey (rowResult row) (resultIx table),+      childColumnIx =+        deleteChildColumnValueIndex rowKey (rowChildrenArray row) (childColumnIx table),+      exactIx =+        deleteExactIndex rowKey (rowChildrenArray row) (exactIx table),+      childUserIx =+        PrimArray.foldrPrimArray+          (deleteChildUserIndex rowKey)+          (childUserIx table)+          (rowChildrenArray row)+    }+{-# INLINE deleteRowFromDerivedIndexes #-}++ensureDerivedIndexes :: OperatorTable f -> OperatorTable f+ensureDerivedIndexes table+  | derivedIndexWatermark table >= nextRowId table =+      table+  | otherwise =+      ( foldUnindexedOperatorTableRowsWithId+          (\indexedTable rowKey row -> insertRowIntoDerivedIndexes rowKey row indexedTable)+          table+          table+      )+        { derivedIndexWatermark = nextRowId table+        }+{-# INLINE ensureDerivedIndexes #-}++foldOperatorTableRowsWithId ::+  (result -> Int -> DatabaseRow -> result) ->+  result ->+  OperatorTable f ->+  result+foldOperatorTableRowsWithId step initialResult table =+  foldOperatorTableRowsFromId 0 step initialResult table+{-# INLINE foldOperatorTableRowsWithId #-}++foldUnindexedOperatorTableRowsWithId ::+  (result -> Int -> DatabaseRow -> result) ->+  result ->+  OperatorTable f ->+  result+foldUnindexedOperatorTableRowsWithId step initialResult table =+  foldOperatorTableRowsFromId (derivedIndexWatermark table) step initialResult table+{-# INLINE foldUnindexedOperatorTableRowsWithId #-}++foldOperatorTableRowsFromId ::+  Int ->+  (result -> Int -> DatabaseRow -> result) ->+  result ->+  OperatorTable f ->+  result+foldOperatorTableRowsFromId firstRowKey step initialResult table =+  foldl'+    (\result (RowId rowKey, row) -> step result rowKey row)+    initialResult+    (dropWhile ((< firstRowKey) . unRowId . fst) (operatorTableRows table))+{-# INLINE foldOperatorTableRowsFromId #-}++unindexedRowIdsWhere :: (DatabaseRow -> Bool) -> OperatorTable f -> RowIdSet+unindexedRowIdsWhere predicate table =+  RowIdSet $+    foldUnindexedOperatorTableRowsWithId+      (\matchingRowIds rowKey row ->+         if predicate row+           then IntSet.insert rowKey matchingRowIds+           else matchingRowIds)+      IntSet.empty+      table+{-# INLINE unindexedRowIdsWhere #-}++insertEncodedRow :: DatabaseRow -> OperatorTable f -> OperatorTable f+insertEncodedRow row table+  | encodedRowPresent row table = table+  | otherwise = appendEncodedRow row table+{-# INLINE insertEncodedRow #-}++insertEncodedRowsWithInsertedRows :: [DatabaseRow] -> OperatorTable f -> ([(RowId, DatabaseRow)], OperatorTable f)+insertEncodedRowsWithInsertedRows rows table =+  case indexedAcceptedRows of+    [] ->+      ([], table)+    _ ->+      ( fmap (\(rowKey, row) -> (RowId rowKey, row)) indexedAcceptedRows,+        table+          { rowStore =+              foldl'+                (\store (_rowKey, row) -> appendStoredRow (opArity table) row store)+                (rowStore table)+                indexedAcceptedRows,+            nextRowId =+              acceptedNextRowId acceptance,+            exactResultIx =+              acceptedExactResultIndex acceptance+          }+      )+  where+    acceptance =+      acceptEncodedRows rows table+    indexedAcceptedRows =+      reverse (acceptedReversedRows acceptance)+{-# INLINE insertEncodedRowsWithInsertedRows #-}++type EncodedRowAcceptance :: Type+data EncodedRowAcceptance = EncodedRowAcceptance+  { acceptedReversedRows :: ![(Int, DatabaseRow)],+    acceptedNextRowId :: !Int,+    acceptedExactResultIndex :: !ExactResultIndex+  }++acceptEncodedRows :: [DatabaseRow] -> OperatorTable f -> EncodedRowAcceptance+acceptEncodedRows rows table =+  foldl'+    acceptEncodedRow+    ( EncodedRowAcceptance+        { acceptedReversedRows = [],+          acceptedNextRowId = nextRowId table,+          acceptedExactResultIndex = exactResultIx table+        }+    )+    rows+  where+    acceptEncodedRow ::+      EncodedRowAcceptance ->+      DatabaseRow ->+      EncodedRowAcceptance+    acceptEncodedRow acceptance row+      | IntSet.member+          (rowResult row)+          (lookupExactResultIndex (rowChildrenArray row) (acceptedExactResultIndex acceptance)) =+          acceptance+      | otherwise =+          acceptance+            { acceptedReversedRows =+                (rowKey, row) : acceptedReversedRows acceptance,+              acceptedNextRowId = rowKey + 1,+              acceptedExactResultIndex =+                insertExactResultIndex+                  (rowResult row)+                  (rowChildrenArray row)+                  (acceptedExactResultIndex acceptance)+            }+      where+        rowKey =+          acceptedNextRowId acceptance+{-# INLINE acceptEncodedRows #-}++appendEncodedRow :: DatabaseRow -> OperatorTable f -> OperatorTable f+appendEncodedRow row table =+  applyOperatorTableRowEdit (InsertOperatorTableRow row) $+    table+      { rowStore = appendStoredRow (opArity table) row (rowStore table),+        nextRowId = rowKey + 1+      }+  where+    rowKey = nextRowId table+{-# INLINE appendEncodedRow #-}++encodedRowPresent :: DatabaseRow -> OperatorTable f -> Bool+encodedRowPresent row table =+  IntSet.member+    (rowResult row)+    (lookupExactResultIndex (rowChildrenArray row) (exactResultIx table))+{-# INLINE encodedRowPresent #-}++operatorTableRows :: OperatorTable f -> [(RowId, DatabaseRow)]+operatorTableRows table =+  concat (toList sealedRowsByChunk) <> pendingRows+  where+    store =+      rowStore table+    tombstones =+      tombstonedRowIds store+    sealedRowsByChunk =+      Seq.mapWithIndex+        (\chunkIndex ->+           operatorRowChunkRowsAt+             (chunkIndex * operatorRowChunkCapacity)+             (opArity table)+             tombstones)+        (sealedRowChunks store)+    pendingRows =+      mapMaybe pendingRow (zip pendingRowKeys (toList (pendingStoredRows store)))+    pendingRowKeys =+      ascendingRowKeysBetween (sealedRowCount table) (nextRowId table)+    pendingRow (rowKey, row)+      | IntSet.member rowKey tombstones =+          Nothing+      | otherwise =+          Just (RowId rowKey, row)++operatorRowChunkRowsAt :: Int -> Int -> IntSet -> OperatorRowChunk -> [(RowId, DatabaseRow)]+operatorRowChunkRowsAt firstRowKey arity tombstones chunk+  | SmallArray.sizeofSmallArray childColumns /= arity =+      []+  | not (all ((== rowCount) . PrimArray.sizeofPrimArray) (smallArrayToList childColumns)) =+      []+  | otherwise =+      fmap rowAt liveRowOffsets+  where+    resultColumn =+      chunkResults chunk+    childColumns =+      chunkChildren chunk+    rowCount =+      PrimArray.sizeofPrimArray resultColumn+    liveRowOffsets =+      filter+        (\rowOffset -> not (IntSet.member (firstRowKey + rowOffset) tombstones))+        (ascendingRowKeys rowCount)+    rowAt rowOffset =+      ( RowId (firstRowKey + rowOffset),+        DatabaseRow+          { rowResult = PrimArray.indexPrimArray resultColumn rowOffset,+            rowChildrenArray =+              PrimArray.generatePrimArray arity $ \childIndex ->+                PrimArray.indexPrimArray+                  (SmallArray.indexSmallArray childColumns childIndex)+                  rowOffset+          }+      )+{-# INLINE operatorRowChunkRowsAt #-}++operatorTableRowsForResultKey :: Int -> OperatorTable f -> [(RowId, DatabaseRow)]+operatorTableRowsForResultKey resultKey table =+  rowsForIds table (operatorTableRowIdsForResultKeys (IntSet.singleton resultKey) table)++operatorTableRowIdsForResultKeys :: IntSet -> OperatorTable f -> RowIdSet+operatorTableRowIdsForResultKeys resultKeys table =+  rowIdSetUnion indexedRowIds unindexedRowIds+  where+    indexedRowIds =+      RowIdSet+        (intMapDependentsOfMany (IntSet.toAscList resultKeys) (derivedResultIndex table))+    unindexedRowIds =+      unindexedRowIdsWhere+        (\row -> IntSet.member (rowResult row) resultKeys)+        table+{-# INLINE operatorTableRowIdsForResultKeys #-}++lookupChildResultKeys :: PrimArray Int -> OperatorTable f -> IntSet+lookupChildResultKeys childKeys table =+  lookupExactResultIndex childKeys (exactResultIx table)++rowsForIds :: OperatorTable f -> RowIdSet -> [(RowId, DatabaseRow)]+rowsForIds table rowIds =+  mapMaybe rowForId (rowIdSetToAscList rowIds)+  where+    rowForId rowKey =+      fmap (\row -> (RowId rowKey, row)) (operatorTableRowAt rowKey table)++deleteEncodedRows :: DatabaseRow -> OperatorTable f -> OperatorTable f+deleteEncodedRows row table+  | encodedRowPresent row table =+      rowIdSetFoldl'+        (flip deleteEncodedRow)+        indexedTable+        ( rowIdSetIntersection+            (lookupResultIndex (rowResult row) (derivedResultIndex indexedTable))+            (lookupExactIndexArray (rowChildrenArray row) (derivedExactIndex indexedTable))+        )+  | otherwise =+      table+  where+    indexedTable =+      ensureDerivedIndexes table++deleteEncodedRow :: Int -> OperatorTable f -> OperatorTable f+deleteEncodedRow rowKey table =+  maybe table (\row -> deleteStoredRow rowKey row table) (operatorTableRowAt rowKey table)++deleteStoredRow :: Int -> DatabaseRow -> OperatorTable f -> OperatorTable f+deleteStoredRow rowKey row table =+  applyOperatorTableRowEdit (DeleteOperatorTableRow rowKey row) $+    table+      { rowStore =+          (rowStore table)+            { tombstonedRowIds =+                IntSet.insert rowKey (tombstonedRowIds (rowStore table))+            }+      }++operatorTableRowAt :: Int -> OperatorTable f -> Maybe DatabaseRow+operatorTableRowAt rowKey table+  | rowKey < 0 || rowKey >= nextRowId table =+      Nothing+  | IntSet.member rowKey (tombstonedRowIds (rowStore table)) =+      Nothing+  | rowKey < sealedRowCount table =+      sealedRowChunkAt rowKey table >>= operatorRowChunkRowAt (opArity table) (rowKey `mod` operatorRowChunkCapacity)+  | otherwise =+      Seq.lookup (rowKey - sealedRowCount table) (pendingStoredRows (rowStore table))+{-# INLINE operatorTableRowAt #-}++operatorTableResultAt :: Int -> OperatorTable f -> Maybe Int+operatorTableResultAt rowKey table+  | rowKey < 0 || rowKey >= nextRowId table =+      Nothing+  | IntSet.member rowKey (tombstonedRowIds (rowStore table)) =+      Nothing+  | rowKey < sealedRowCount table =+      sealedRowChunkAt rowKey table >>= operatorRowChunkResultAt (rowKey `mod` operatorRowChunkCapacity)+  | otherwise =+      rowResult <$> Seq.lookup (rowKey - sealedRowCount table) (pendingStoredRows (rowStore table))+{-# INLINE operatorTableResultAt #-}++sealedRowCount :: OperatorTable f -> Int+sealedRowCount table =+  Seq.length (sealedRowChunks (rowStore table)) * operatorRowChunkCapacity+{-# INLINE sealedRowCount #-}++sealedRowChunkAt :: Int -> OperatorTable f -> Maybe OperatorRowChunk+sealedRowChunkAt rowKey table =+  Seq.lookup+    (rowKey `div` operatorRowChunkCapacity)+    (sealedRowChunks (rowStore table))+{-# INLINE sealedRowChunkAt #-}++operatorRowChunkRowAt :: Int -> Int -> OperatorRowChunk -> Maybe DatabaseRow+operatorRowChunkRowAt arity rowOffset chunk+  | rowOffset < 0 || rowOffset >= rowCount =+      Nothing+  | SmallArray.sizeofSmallArray childColumns /= arity =+      Nothing+  | not (all ((== rowCount) . PrimArray.sizeofPrimArray) (smallArrayToList childColumns)) =+      Nothing+  | otherwise =+      Just+        DatabaseRow+          { rowResult = PrimArray.indexPrimArray resultColumn rowOffset,+            rowChildrenArray =+              PrimArray.generatePrimArray arity $ \childIndex ->+                PrimArray.indexPrimArray+                  (SmallArray.indexSmallArray childColumns childIndex)+                  rowOffset+          }+  where+    resultColumn =+      chunkResults chunk+    childColumns =+      chunkChildren chunk+    rowCount =+      PrimArray.sizeofPrimArray resultColumn+{-# INLINE operatorRowChunkRowAt #-}++operatorRowChunkResultAt :: Int -> OperatorRowChunk -> Maybe Int+operatorRowChunkResultAt rowOffset chunk =+  if rowOffset < 0 || rowOffset >= PrimArray.sizeofPrimArray results+    then Nothing+    else Just (PrimArray.indexPrimArray results rowOffset)+  where+    results =+      chunkResults chunk+{-# INLINE operatorRowChunkResultAt #-}++ascendingRowKeys :: Int -> [Int]+ascendingRowKeys count =+  ascendingRowKeysBetween 0 count+{-# INLINE ascendingRowKeys #-}++ascendingRowKeysBetween :: Int -> Int -> [Int]+ascendingRowKeysBetween firstRowKey endRowKey+  | firstRowKey >= endRowKey = []+  | otherwise = [max 0 firstRowKey .. endRowKey - 1]+{-# INLINE ascendingRowKeysBetween #-}++childValueAt :: Int -> PrimArray Int -> Maybe Int+childValueAt childIndex children =+  if childIndex < 0 || childIndex >= PrimArray.sizeofPrimArray children+    then Nothing+    else Just (PrimArray.indexPrimArray children childIndex)+{-# INLINE childValueAt #-}++keepNonEmptyTable :: OperatorTable f -> Maybe (OperatorTable f)+keepNonEmptyTable table+  | tableLiveRowCount table == 0 = Nothing+  | otherwise = Just table
+ src-term/Moonlight/Core/Term/Database/Pattern.hs view
@@ -0,0 +1,78 @@+module Moonlight.Core.Term.Database.Pattern where++import Data.Foldable (toList)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Data.Traversable (mapAccumL)+import Moonlight.Core.Pattern+  ( Pattern (..),+    patternVariables,+  )+import Moonlight.Core.Term.Database.Types+import Prelude++compilePatternFreeJoinPlan ::+  Traversable f =>+  Pattern f ->+  PatternFreeJoinPlan f key+compilePatternFreeJoinPlan patternValue =+  compilePatternsFreeJoinPlan (patternValue :| [])+{-# INLINE compilePatternFreeJoinPlan #-}++compilePatternsFreeJoinPlan ::+  Traversable f =>+  NonEmpty (Pattern f) ->+  PatternFreeJoinPlan f key+compilePatternsFreeJoinPlan patterns =+  PatternFreeJoinPlan+    { patternFreeJoinPlan =+        FreeJoinPlan (reverse (compileAtoms finalState)),+      patternFreeJoinRoots = rootTerms,+      patternFreeJoinVariables = queryVarsByPatternVar+    }+  where+    patternVars =+      foldMap patternVariables patterns++    queryVarsByPatternVar =+      Map.fromSet AuthoredPatternVar patternVars++    initialState :: PatternCompileState f key+    initialState =+      PatternCompileState+        { nextGeneratedPatternNodeVar = 0,+          compileAtoms = []+        }++    (finalState, rootTerms) =+      mapAccumL compilePatternTerm initialState patterns+{-# INLINE compilePatternsFreeJoinPlan #-}++compilePatternTerm ::+  Traversable f =>+  PatternCompileState f key ->+  Pattern f ->+  (PatternCompileState f key, QueryTerm key)+compilePatternTerm state patternValue =+  case patternValue of+    PatternVar patternVar ->+      (state, QueryVariable (AuthoredPatternVar patternVar))+    PatternNode node ->+      let resultTerm =+            QueryVariable (GeneratedPatternNodeVar (nextGeneratedPatternNodeVar state))+          stateAfterResult =+            state {nextGeneratedPatternNodeVar = nextGeneratedPatternNodeVar state + 1}+          (stateAfterChildren, childTerms) =+            mapAccumL compilePatternTerm stateAfterResult node+          atom =+            QueryAtom+              { atomOperator = extractOperator node,+                atomResult = resultTerm,+                atomChildren = toList childTerms+              }+       in ( stateAfterChildren+              { compileAtoms = atom : compileAtoms stateAfterChildren+              },+            resultTerm+          )+{-# INLINE compilePatternTerm #-}
+ src-term/Moonlight/Core/Term/Database/Projection.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE QuantifiedConstraints #-}++module Moonlight.Core.Term.Database.Projection 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 (Map)+import Data.Map.Strict qualified as Map+import Data.Primitive.PrimArray qualified as PrimArray+import Moonlight.Core.Term.Database.Index+import Moonlight.Core.Term.Database.OperatorTable+import Moonlight.Core.Term.Database.Types+import Prelude++dirtyRowsForKeys :: Database f key -> IntSet -> Map (Operator f) RowIdSet+dirtyRowsForKeys database keys =+  operatorMapFromIds database (dirtyRowsForKeysByOperatorId database keys)++dirtyRowsForKeysByOperatorId :: Database f key -> IntSet -> IntMap RowIdSet+dirtyRowsForKeysByOperatorId database keys =+  IntMap.filter (not . rowIdSetNull) (fmap dirtyRows tables)+  where+    tables =+      operatorTables database+    dirtyRows table =+      rowIdSetUnion+        indexedDirtyRows+        (unindexedRowIdsWhere (rowReferencesAnyKey keys) table)+      where+        indexedDirtyRows =+          rowIdSetUnion+            (RowIdSet (intMapDependentsOfMany keyList (derivedResultIndex table)))+            (RowIdSet (intMapDependentsOfMany keyList (derivedChildUserIndex table)))+    keyList =+      IntSet.toAscList keys++operatorRows :: Database f key -> Map (Operator f) [(RowId, DatabaseRow)]+operatorRows database =+  operatorMapFromIds database (operatorRowsByOperatorId database)++operatorRowsByOperatorId :: Database f key -> IntMap [(RowId, DatabaseRow)]+operatorRowsByOperatorId =+  fmap operatorTableRows . operatorTables++operatorMapFromIds :: Database f key -> IntMap value -> Map (Operator f) value+operatorMapFromIds database valuesByOperatorId =+  Map.mapMaybe (`IntMap.lookup` valuesByOperatorId) (operatorIds database)+{-# INLINE operatorMapFromIds #-}++operatorMapFromShapes ::+  (forall a. Ord a => Ord (f a)) =>+  Database f key ->+  IntMap value ->+  Map (Operator f) value+operatorMapFromShapes database =+  IntMap.foldlWithKey' projectOperatorValue Map.empty+  where+    projectOperatorValue valuesByOperator operatorId value =+      maybe+        valuesByOperator+        (\operator -> Map.insert operator value valuesByOperator)+        (IntMap.lookup operatorId (operatorShapes database))+{-# INLINE operatorMapFromShapes #-}++resultKeys :: Database f key -> IntSet+resultKeys database =+  IntMap.foldl' collectTable IntSet.empty tables+  where+    tables =+      operatorTables database+    collectTable :: IntSet -> OperatorTable f -> IntSet+    collectTable accumulatedResultKeys table =+      rowIdSetFoldl'+        (insertLiveTableRowResult table)+        accumulatedResultKeys+        (tableLiveRows table)+{-# INLINE resultKeys #-}++resultKeysUsingAnyChildKey :: IntSet -> Database f key -> IntSet+resultKeysUsingAnyChildKey keys database =+  IntMap.foldl' collectTable IntSet.empty tables+  where+    tables =+      operatorTables database+    keyList =+      IntSet.toAscList keys+    collectTable :: IntSet -> OperatorTable f -> IntSet+    collectTable accumulatedResultKeys table =+      rowIdSetFoldl'+        (insertLiveTableRowResult table)+        accumulatedResultKeys+        (rowIdSetUnion+            (RowIdSet (intMapDependentsOfMany keyList (derivedChildUserIndex table)))+            (unindexedRowIdsWhere (rowUsesAnyChildKey keys) table)+        )+{-# INLINE resultKeysUsingAnyChildKey #-}++rowReferencesAnyKey :: IntSet -> DatabaseRow -> Bool+rowReferencesAnyKey keys row =+  IntSet.member (rowResult row) keys+    || rowUsesAnyChildKey keys row+{-# INLINE rowReferencesAnyKey #-}++rowUsesAnyChildKey :: IntSet -> DatabaseRow -> Bool+rowUsesAnyChildKey keys row =+  PrimArray.foldrPrimArray+    (\childKey childMatched -> IntSet.member childKey keys || childMatched)+    False+    (rowChildrenArray row)+{-# INLINE rowUsesAnyChildKey #-}++insertLiveTableRowResult :: OperatorTable f -> IntSet -> Int -> IntSet+insertLiveTableRowResult table accumulatedResultKeys rowKey =+  maybe+    accumulatedResultKeys+    (`IntSet.insert` accumulatedResultKeys)+    (operatorTableResultAt rowKey table)+{-# INLINE insertLiveTableRowResult #-}++rowsForOperator :: (forall a. Ord a => Ord (f a)) => Operator f -> Database f key -> [(RowId, DatabaseRow)]+rowsForOperator operator database =+  maybe [] operatorTableRows (operatorTableFor operator database)++operatorRowsForIds ::+  (forall a. Ord a => Ord (f a)) =>+  Operator f ->+  RowIdSet ->+  Database f key ->+  [(RowId, DatabaseRow)]+operatorRowsForIds operator rowIds database =+  maybe [] (`rowsForIds` rowIds) (operatorTableFor operator database)++operatorRowsForIdsByOperatorId :: Int -> RowIdSet -> Database f key -> [(RowId, DatabaseRow)]+operatorRowsForIdsByOperatorId operatorId rowIds database =+  maybe [] (`rowsForIds` rowIds) (IntMap.lookup operatorId (operatorTables database))++rowsForResultKey :: (forall a. Ord a => Ord (f a)) => Int -> Operator f -> Database f key -> [(RowId, DatabaseRow)]+rowsForResultKey resultKey operator database =+  maybe [] rowsForTable (operatorTableFor operator database)+  where+    rowsForTable table =+      rowsForIds table (operatorTableRowIdsForResultKeys (IntSet.singleton resultKey) table)++rowsForResultKeys :: (forall a. Ord a => Ord (f a)) => IntSet -> Operator f -> Database f key -> [(RowId, DatabaseRow)]+rowsForResultKeys encodedResultKeys operator database =+  maybe [] rowsForTable (operatorTableFor operator database)+  where+    rowsForTable table =+      rowsForIds table (operatorTableRowIdsForResultKeys encodedResultKeys table)++operatorTableFor :: (forall a. Ord a => Ord (f a)) => Operator f -> Database f key -> Maybe (OperatorTable f)+operatorTableFor operator database =+  operatorIdFor operator database+    >>= \operatorId -> IntMap.lookup operatorId (operatorTables database)+{-# INLINE operatorTableFor #-}
+ src-term/Moonlight/Core/Term/Database/Table.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Moonlight.Core.Term.Database.Table where++import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Map.Strict qualified as Map+import Moonlight.Core.DenseKey (DenseKey (..))+import Moonlight.Core.Language (Language)+import Moonlight.Core.Term.Database.Encode+import Moonlight.Core.Term.Database.OperatorTable+import Moonlight.Core.Term.Database.Types+import Prelude++insertTuple ::+  (DenseKey key, Language f) =>+  key ->+  f key ->+  Database f key ->+  Database f key+insertTuple resultValue tupleValue =+  insertEncodedDatabaseRow+    (extractOperator tupleValue)+    (encodedRow resultValue tupleValue)+{-# INLINE insertTuple #-}++insertTuples ::+  forall key f.+  (DenseKey key, Language f) =>+  [(key, f key)] ->+  Database f key ->+  Database f key+insertTuples entries database =+  snd (insertTuplesWithInsertedRows entries database)++insertTuplesWithInsertedRows ::+  forall key f.+  (DenseKey key, Language f) =>+  [(key, f key)] ->+  Database f key ->+  (IntMap [(RowId, DatabaseRow)], Database f key)+insertTuplesWithInsertedRows entries database =+  IntMap.foldlWithKey'+    insertOperatorRows+    (IntMap.empty, internedDatabase)+    rowsByOperatorId+  where+    (internedDatabase, rowsByOperatorId) =+      foldl'+        collectRowsByOperatorId+        (database, IntMap.empty)+        entries++    insertOperatorRows ::+      (IntMap [(RowId, DatabaseRow)], Database f key) ->+      Int ->+      (Operator f, [DatabaseRow]) ->+      (IntMap [(RowId, DatabaseRow)], Database f key)+    insertOperatorRows (insertedRows, currentDatabase) operatorId (operator, reversedRows) =+      ( insertOperatorInsertedRows operatorId operatorInsertedRows insertedRows,+        updatedDatabase+      )+      where+        (operatorInsertedRows, updatedDatabase) =+          insertEncodedDatabaseRowsWithInsertedRows+            operatorId+            operator+            (reverse reversedRows)+            currentDatabase++    collectRowsByOperatorId ::+      (Database f key, IntMap (Operator f, [DatabaseRow])) ->+      (key, f key) ->+      (Database f key, IntMap (Operator f, [DatabaseRow]))+    collectRowsByOperatorId (currentDatabase, operatorRows) (resultValue, tupleValue) =+      ( internedOperatorDatabase,+        IntMap.insertWith+          prependOperatorRows+          operatorId+          (operator, [encodedRow resultValue tupleValue])+          operatorRows+      )+      where+        operator =+          extractOperator tupleValue+        (operatorId, internedOperatorDatabase) =+          internOperator operator currentDatabase++    prependOperatorRows ::+      (Operator f, [DatabaseRow]) ->+      (Operator f, [DatabaseRow]) ->+      (Operator f, [DatabaseRow])+    prependOperatorRows (_newOperator, newRows) (operator, existingRows) =+      (operator, newRows <> existingRows)++    insertOperatorInsertedRows ::+      Int ->+      [(RowId, DatabaseRow)] ->+      IntMap [(RowId, DatabaseRow)] ->+      IntMap [(RowId, DatabaseRow)]+    insertOperatorInsertedRows operatorId rows insertedRows =+      case rows of+        [] ->+          insertedRows+        _ ->+          IntMap.insert operatorId rows insertedRows++insertEncodedDatabaseRow ::+  (Foldable f, forall a. Ord a => Ord (f a)) =>+  Operator f ->+  DatabaseRow ->+  Database f key ->+  Database f key+insertEncodedDatabaseRow operator@(Operator shape) row database =+  case nextRowId updatedTable == nextRowId table of+    True ->+      internedDatabase+    False ->+      invalidateOperatorArrangements operatorId $+        internedDatabase+          { operatorTables =+              IntMap.insert operatorId updatedTable (operatorTables internedDatabase)+          }+  where+    (operatorId, internedDatabase) =+      internOperator operator database+    table =+      IntMap.findWithDefault+        (emptyOperatorTable shape)+        operatorId+        (operatorTables internedDatabase)+    updatedTable =+      insertEncodedRow row table+{-# INLINE insertEncodedDatabaseRow #-}++insertEncodedDatabaseRowsWithInsertedRows ::+  Foldable f =>+  Int ->+  Operator f ->+  [DatabaseRow] ->+  Database f key ->+  ([(RowId, DatabaseRow)], Database f key)+insertEncodedDatabaseRowsWithInsertedRows _operatorId _operator [] database =+  ([], database)+insertEncodedDatabaseRowsWithInsertedRows operatorId (Operator shape) rows database =+  case insertedRows of+    [] ->+      ([], database)+    _ ->+      ( insertedRows,+        invalidateOperatorArrangements operatorId $+          database+            { operatorTables =+                IntMap.insert operatorId updatedTable (operatorTables database)+            }+      )+  where+    table =+      IntMap.findWithDefault+        (emptyOperatorTable shape)+        operatorId+        (operatorTables database)+    (insertedRows, updatedTable) =+      insertEncodedRowsWithInsertedRows rows table++internOperator ::+  (forall a. Ord a => Ord (f a)) =>+  Operator f ->+  Database f key ->+  (Int, Database f key)+internOperator operator database =+  case Map.lookup operator (operatorIds database) of+    Just operatorId ->+      (operatorId, database)+    Nothing ->+      ( operatorId,+        database+          { operatorIds = Map.insert operator operatorId (operatorIds database),+            operatorShapes = IntMap.insert operatorId operator (operatorShapes database),+            nextOperatorId = operatorId + 1+          }+      )+      where+        operatorId =+          nextOperatorId database+{-# INLINE internOperator #-}++deleteRow ::+  (forall a. Ord a => Ord (f a)) =>+  Operator f ->+  RowId ->+  Database f key ->+  Database f key+deleteRow operator (RowId rowKey) database =+  deleteOperatorRows operator (deleteEncodedRow rowKey) database++deleteTuple ::+  (DenseKey key, Language f) =>+  key ->+  f key ->+  Database f key ->+  Database f key+deleteTuple resultValue tupleValue database =+  deleteOperatorRows operator (deleteEncodedRows row) database+  where+    operator =+      extractOperator tupleValue+    row =+      encodedRow resultValue tupleValue++deleteOperatorRows ::+  (forall a. Ord a => Ord (f a)) =>+  Operator f ->+  (OperatorTable f -> OperatorTable f) ->+  Database f key ->+  Database f key+deleteOperatorRows operator deleteRows database =+  case operatorIdFor operator database of+    Nothing ->+      database+    Just operatorId ->+      deleteOperatorRowsByOperatorId operatorId deleteRows database++deleteOperatorRowsByOperatorId ::+  Int ->+  (OperatorTable f -> OperatorTable f) ->+  Database f key ->+  Database f key+deleteOperatorRowsByOperatorId operatorId deleteRows database =+  case IntMap.lookup operatorId (operatorTables database) of+    Nothing ->+      database+    Just table ->+      let updatedTable =+            deleteRows table+       in if tableLiveRowCount updatedTable == tableLiveRowCount table+            then database+            else+              invalidateOperatorArrangements operatorId $+                database+                  { operatorTables =+                      IntMap.update+                        (const (keepNonEmptyTable updatedTable))+                        operatorId+                        (operatorTables database)+                  }++ensureOperatorDerivedIndexes ::+  Int ->+  Database f key ->+  Database f key+ensureOperatorDerivedIndexes operatorId database =+  case IntMap.lookup operatorId (operatorTables database) of+    Just table+      | derivedIndexWatermark table /= nextRowId table ->+          database+            { operatorTables =+                IntMap.insert+                  operatorId+                  (ensureDerivedIndexes table)+                  (operatorTables database)+            }+    _ ->+      database+{-# INLINE ensureOperatorDerivedIndexes #-}++invalidateOperatorArrangements :: Int -> Database f key -> Database f key+invalidateOperatorArrangements operatorId database =+  case IntMap.null (arrangements database) of+    True ->+      database+    False ->+      database+        { arrangements =+            IntMap.delete operatorId (arrangements database)+        }+{-# INLINE invalidateOperatorArrangements #-}++compact :: Foldable f => Database f key -> Database f key+compact database =+  database+    { operatorTables =+        IntMap.mapMaybe compactOperatorTable (operatorTables database),+      arrangements = IntMap.empty+    }+{-# INLINE compact #-}++compactOperatorTable :: Foldable f => OperatorTable f -> Maybe (OperatorTable f)+compactOperatorTable table =+  keepNonEmptyTable (operatorTableFromRows (opShape table) (snd <$> operatorTableRows table))+{-# INLINE compactOperatorTable #-}
+ src-term/Moonlight/Core/Term/Database/Transaction.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE QuantifiedConstraints #-}++module Moonlight.Core.Term.Database.Transaction where++import Control.Monad.ST (ST, runST)+import Data.Functor (void)+import Data.STRef+  ( modifySTRef',+    newSTRef,+    readSTRef,+    writeSTRef,+  )+import Moonlight.Core.DenseKey (DenseKey)+import Moonlight.Core.Language (Language)+import Moonlight.Core.Term.Database.Command+import Moonlight.Core.Term.Database.Table+import Moonlight.Core.Term.Database.Types+import Prelude++runCommandTransaction ::+  (Ord key, Language f) =>+  Database f key ->+  (forall s. DatabaseEditor s f key -> ST s result) ->+  (result, [TermCommand f key], Database f key)+runCommandTransaction =+  runTransactionWithCommands normalizeTermCommands+{-# INLINE runCommandTransaction #-}++runTransactionWithCommands ::+  ([TermCommand f key] -> [TermCommand f key]) ->+  Database f key ->+  (forall s. DatabaseEditor s f key -> ST s result) ->+  (result, [TermCommand f key], Database f key)+runTransactionWithCommands normalizeResidualCommands database action =+  runST $ do+    workingRef <- newSTRef database+    residualRef <- newSTRef []+    controlRef <- newSTRef CommitDatabaseTransaction+    let editor =+          DatabaseEditor+            { workingRef = workingRef,+              residualCommandsRef = residualRef,+              controlRef = controlRef+            }+    result <- action editor+    control <- readSTRef controlRef+    workingDatabase <- readSTRef workingRef+    residualCommands <- readSTRef residualRef+    let (committedCommands, committedDatabase) =+          case control of+            CommitDatabaseTransaction ->+              (normalizeResidualCommands residualCommands, workingDatabase)+            AbortDatabaseTransaction ->+              ([], database)+    pure (result, committedCommands, committedDatabase)+{-# INLINE runTransactionWithCommands #-}++editorSnapshot :: DatabaseEditor s f key -> ST s (Database f key)+editorSnapshot =+  readSTRef . workingRef+{-# INLINE editorSnapshot #-}++editorQueueCommands ::+  (DenseKey key, Language f) =>+  [TermCommand f key] ->+  DatabaseEditor s f key ->+  ST s (TermCommitResult f key)+editorQueueCommands commands editor =+  modifyEditorWithResiduals editor (commitTermCommands commands)+{-# INLINE editorQueueCommands #-}++editorInsertTuple ::+  (DenseKey key, Language f) =>+  key ->+  f key ->+  DatabaseEditor s f key ->+  ST s ()+editorInsertTuple resultValue tupleValue editor =+  void (editorQueueCommands [InsertTerm resultValue tupleValue] editor)+{-# INLINE editorInsertTuple #-}++editorDeleteRow ::+  (forall a. Ord a => Ord (f a)) =>+  Operator f ->+  RowId ->+  DatabaseEditor s f key ->+  ST s ()+editorDeleteRow operator rowId editor =+  modifyEditor editor (deleteRow operator rowId)+{-# INLINE editorDeleteRow #-}++editorDeleteTuple ::+  (DenseKey key, Language f) =>+  key ->+  f key ->+  DatabaseEditor s f key ->+  ST s ()+editorDeleteTuple resultValue tupleValue editor =+  modifyEditor editor (deleteTuple resultValue tupleValue)+{-# INLINE editorDeleteTuple #-}++editorReplaceTuple ::+  (DenseKey key, Language f) =>+  key ->+  f key ->+  key ->+  f key ->+  DatabaseEditor s f key ->+  ST s ()+editorReplaceTuple oldResult oldTuple newResult newTuple editor =+  void $+    modifyEditorWithResiduals+      editor+      (commitTermCommands [InsertTerm newResult newTuple] . deleteTuple oldResult oldTuple)+{-# INLINE editorReplaceTuple #-}++editorCompact :: Foldable f => DatabaseEditor s f key -> ST s ()+editorCompact editor =+  modifyEditor editor compact+{-# INLINE editorCompact #-}++abortTransaction :: DatabaseEditor s f key -> ST s ()+abortTransaction editor =+  writeSTRef (controlRef editor) AbortDatabaseTransaction+{-# INLINE abortTransaction #-}++modifyEditor :: DatabaseEditor s f key -> (Database f key -> Database f key) -> ST s ()+modifyEditor editor update =+  modifySTRef' (workingRef editor) update+{-# INLINE modifyEditor #-}++modifyEditorWithResiduals ::+  DatabaseEditor s f key ->+  (Database f key -> TermCommitResult f key) ->+  ST s (TermCommitResult f key)+modifyEditorWithResiduals editor update = do+  database <- readSTRef (workingRef editor)+  let commitResult = update database+  writeSTRef (workingRef editor) (committedDatabase commitResult)+  appendEditorResiduals editor (residualCommands commitResult)+  pure commitResult+{-# INLINE modifyEditorWithResiduals #-}++appendEditorResiduals :: DatabaseEditor s f key -> [TermCommand f key] -> ST s ()+appendEditorResiduals editor residualCommands =+  modifySTRef'+    (residualCommandsRef editor)+    (residualCommands <>)+{-# INLINE appendEditorResiduals #-}
+ src-term/Moonlight/Core/Term/Database/Types.hs view
@@ -0,0 +1,478 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RoleAnnotations #-}++module Moonlight.Core.Term.Database.Types where++import Data.Foldable (toList, traverse_)+import Data.Functor (void)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Primitive.PrimArray (PrimArray)+import Data.Primitive.PrimArray qualified as PrimArray+import Data.Primitive.SmallArray (SmallArray)+import Data.Primitive.SmallArray qualified as SmallArray+import Data.Sequence (Seq)+import Data.STRef (STRef)+import Data.Vector.Unboxed qualified as U+import Moonlight.Core.Identifier.EGraph (PatternVar)+import Numeric.Natural (Natural)+import Prelude++type Operator :: (Type -> Type) -> Type+newtype Operator f = Operator {unOperator :: f ()}+type role Operator representational++instance (forall a. Ord a => Ord (f a)) => Eq (Operator f) where+  Operator left == Operator right = left == right++instance (forall a. Ord a => Ord (f a)) => Ord (Operator f) where+  compare (Operator left) (Operator right) = compare left right++instance (forall a. Show a => Show (f a)) => Show (Operator f) where+  showsPrec precedence (Operator value) =+    showParen (precedence > 10) $+      showString "Operator " . showsPrec 11 value++extractOperator :: Traversable f => f key -> Operator f+extractOperator =+  Operator . void++type RowId :: Type+newtype RowId = RowId {unRowId :: Int}+  deriving stock (Eq, Ord, Show)++type RowIdSet :: Type+newtype RowIdSet = RowIdSet+  { unRowIdSet :: IntSet+  }+  deriving stock (Eq, Show)++emptyRowIdSet :: RowIdSet+emptyRowIdSet =+  RowIdSet IntSet.empty++rowIdSetUnion :: RowIdSet -> RowIdSet -> RowIdSet+rowIdSetUnion (RowIdSet left) (RowIdSet right) =+  RowIdSet (IntSet.union left right)++rowIdSetIntersection :: RowIdSet -> RowIdSet -> RowIdSet+rowIdSetIntersection (RowIdSet left) (RowIdSet right) =+  RowIdSet (IntSet.intersection left right)++rowIdSetNull :: RowIdSet -> Bool+rowIdSetNull (RowIdSet rowKeys) =+  IntSet.null rowKeys++rowIdSetSize :: RowIdSet -> Int+rowIdSetSize (RowIdSet rowKeys) =+  IntSet.size rowKeys++rowIdSetFoldl' :: (result -> Int -> result) -> result -> RowIdSet -> result+rowIdSetFoldl' step result (RowIdSet rowKeys) =+  IntSet.foldl' step result rowKeys++rowIdSetToAscList :: RowIdSet -> [Int]+rowIdSetToAscList (RowIdSet rowKeys) =+  IntSet.toAscList rowKeys++type DatabaseRow :: Type+data DatabaseRow = DatabaseRow+  { rowResult :: !Int,+    rowChildrenArray :: !(PrimArray Int)+  }+  deriving stock (Eq, Ord)++instance Show DatabaseRow where+  showsPrec precedence row =+    showParen (precedence > 10) $+      showString "DatabaseRow {rowResult = "+        . shows (rowResult row)+        . showString ", rowChildren = "+        . shows (rowChildren row)+        . showString "}"++rowChildren :: DatabaseRow -> [Int]+rowChildren =+  PrimArray.primArrayToList . rowChildrenArray+{-# INLINE rowChildren #-}++type DatabaseRowDelta :: (Type -> Type) -> Type+-- | Committed non-monotone row edits grouped by operator. Insertions include+-- the row ids assigned by the committed database after duplicate/canonical+-- rows collapse; deletions distinguish this broader change set from the+-- monotone frontier published by 'TermCommitResult'.+data DatabaseRowDelta f = DatabaseRowDelta+  { rowsDeleted :: !(Map (Operator f) [(RowId, DatabaseRow)]),+    rowsInserted :: !(Map (Operator f) [(RowId, DatabaseRow)])+  }++type TermCommitResult :: (Type -> Type) -> Type -> Type+-- | The observable result of one command commit.+--+-- 'insertedRows' is the exact monotone frontier accepted by this commit,+-- grouped by operator. Within each operator its row ids are unique and+-- ascending, every pair is present in 'committedDatabase', and rows already+-- present (or collapsed as duplicates within the commit) are absent. Row ids+-- are snapshot coordinates: 'compact' may rekey them, so this frontier does+-- not promise identifier stability across compaction.+data TermCommitResult f key = TermCommitResult+  { residualCommands :: ![TermCommand f key],+    insertedRows :: !(Map (Operator f) [(RowId, DatabaseRow)]),+    committedDatabase :: !(Database f key)+  }++type TermCommand :: (Type -> Type) -> Type -> Type+data TermCommand f key+  = DeleteRow !(Operator f) !RowId+  | InsertTerm !key !(f key)+  | UnionResults !key !key++type Column :: Type+data Column+  = ResultColumn+  | ChildColumn !Int+  deriving stock (Eq, Ord, Show)++type ArrangementKey :: Type+data ArrangementKey = ArrangementKey !Int !(SmallArray Column)++type ArrangementValidationError :: Type+data ArrangementValidationError+  = NegativeArrangementChildColumn !Int+  | ArrangementChildColumnOutOfBounds !Int !Int+  | ArrangementOperatorArityMismatch !Int !Int+  | ArrangementPrefixTooDeep !Int !Int+  deriving stock (Eq, Show)++instance Eq ArrangementKey where+  ArrangementKey leftArity leftColumns == ArrangementKey rightArity rightColumns =+    leftArity == rightArity+      && smallArrayToList leftColumns == smallArrayToList rightColumns++instance Ord ArrangementKey where+  compare left right =+    compare+      (arrangementKeyArity left, arrangementKeyColumns left)+      (arrangementKeyArity right, arrangementKeyColumns right)++instance Show ArrangementKey where+  showsPrec precedence key =+    showParen (precedence > 10) $+      showString "ArrangementKey "+        . showsPrec 11 (arrangementKeyArity key, arrangementKeyColumns key)++arrangementKeyForOperator :: Foldable f => Operator f -> [Column] -> Either ArrangementValidationError ArrangementKey+arrangementKeyForOperator (Operator shape) columns =+  traverse_ (validateArrangementColumn arity) columns+    *> Right (ArrangementKey arity (SmallArray.smallArrayFromList columns))+  where+    arity =+      length (toList shape)++validateArrangementColumn :: Int -> Column -> Either ArrangementValidationError ()+validateArrangementColumn arity column =+  case column of+    ResultColumn ->+      Right ()+    ChildColumn childIndex+      | childIndex < 0 ->+          Left (NegativeArrangementChildColumn childIndex)+      | childIndex >= arity ->+          Left (ArrangementChildColumnOutOfBounds childIndex arity)+      | otherwise ->+          Right ()++arrangementKeyArity :: ArrangementKey -> Int+arrangementKeyArity (ArrangementKey arity _columns) =+  arity++arrangementKeyColumns :: ArrangementKey -> [Column]+arrangementKeyColumns (ArrangementKey _arity columns) =+  smallArrayToList columns+{-# INLINE arrangementKeyColumns #-}++type ArrangementPrefix :: Type+newtype ArrangementPrefix = ArrangementPrefix+  { unArrangementPrefix :: [Int]+  }+  deriving stock (Eq, Ord, Show)++arrangementPrefixForKey :: ArrangementKey -> [Int] -> Either ArrangementValidationError ArrangementPrefix+arrangementPrefixForKey key prefixValues+  | prefixDepth > keyDepth =+      Left (ArrangementPrefixTooDeep prefixDepth keyDepth)+  | otherwise =+      Right (ArrangementPrefix prefixValues)+  where+    prefixDepth =+      length prefixValues+    keyDepth =+      length (arrangementKeyColumns key)++validateArrangementKeyForOperator :: Foldable f => Operator f -> ArrangementKey -> Either ArrangementValidationError ()+validateArrangementKeyForOperator (Operator shape) key+  | operatorArity == arrangementKeyArity key =+      Right ()+  | otherwise =+      Left (ArrangementOperatorArityMismatch (arrangementKeyArity key) operatorArity)+  where+    operatorArity =+      length (toList shape)++validateArrangementPrefixForKey :: ArrangementKey -> ArrangementPrefix -> Either ArrangementValidationError ()+validateArrangementPrefixForKey key (ArrangementPrefix prefixValues) =+  () <$ arrangementPrefixForKey key prefixValues++type ArrangementNode :: Type+data ArrangementNode+  = OffsetLeaf !RowIdSet+  | PrefixBranch !RowIdSet !(Map Int ArrangementNode)+  deriving stock (Eq, Show)++type Arrangement :: Type+data Arrangement = Arrangement+  { arrangementOrder :: !ArrangementKey,+    arrangementRoot :: !ArrangementNode+  }+  deriving stock (Eq, Show)++type ArrangementCache :: Type+type ArrangementCache = IntMap (Map ArrangementKey Arrangement)++type RelationStats :: Type+data RelationStats = RelationStats+  { rowCount :: !Int,+    liveRowCount :: !Int,+    distinctPerColumn :: !(U.Vector Int),+    distinctPerPrefix :: !(Map ArrangementKey Int),+    maximumBucketSize :: !Int+  }+  deriving stock (Eq, Show)++type QueryVar :: Type+data QueryVar+  = ExplicitQueryVar !Int+  | AuthoredPatternVar !PatternVar+  | GeneratedPatternNodeVar !Natural+  deriving stock (Eq, Ord, Show)++type QueryTerm :: Type -> Type+data QueryTerm key+  = QueryBound !key+  | QueryVariable !QueryVar+  deriving stock (Eq, Ord, Show)++type QueryAtom :: (Type -> Type) -> Type -> Type+data QueryAtom f key = QueryAtom+  { atomOperator :: !(Operator f),+    atomResult :: !(QueryTerm key),+    atomChildren :: ![QueryTerm key]+  }++type FreeJoinPlan :: (Type -> Type) -> Type -> Type+newtype FreeJoinPlan f key = FreeJoinPlan+  { freeJoinAtoms :: [QueryAtom f key]+  }++type FreeJoinStrategy :: Type+data FreeJoinStrategy+  = FreeJoinEmptyConjunction+  | FreeJoinExactAtomProbe+  | FreeJoinGenericIntersection+  deriving stock (Eq, Ord, Show)++type QueryBinding :: Type -> Type+newtype QueryBinding key = QueryBinding+  { queryBindingAssignments :: Map QueryVar key+  }+  deriving stock (Eq, Ord, Show)++type PatternFreeJoinPlan :: (Type -> Type) -> Type -> Type+data PatternFreeJoinPlan f key = PatternFreeJoinPlan+  { patternFreeJoinPlan :: !(FreeJoinPlan f key),+    patternFreeJoinRoots :: !(NonEmpty (QueryTerm key)),+    patternFreeJoinVariables :: !(Map PatternVar QueryVar)+  }++type PatternCompileState :: (Type -> Type) -> Type -> Type+data PatternCompileState f key = PatternCompileState+  { nextGeneratedPatternNodeVar :: !Natural,+    compileAtoms :: ![QueryAtom f key]+  }++type OperatorTableRowEdit :: Type+data OperatorTableRowEdit+  = InsertOperatorTableRow !DatabaseRow+  | DeleteOperatorTableRow !Int !DatabaseRow++type ChildUserIndex :: Type+type ChildUserIndex = IntMap IntSet++type ChildTupleIndex :: Type+data ChildTupleIndex+  = NullaryChildTupleIndex !IntSet+  | UnaryChildTupleIndex !(IntMap IntSet)+  | BinaryChildTupleIndex !(IntMap (IntMap IntSet))+  | NaryChildTupleIndex !(Map ChildTupleKey IntSet)++type ChildTupleKey :: Type+data ChildTupleKey+  = StoredChildTupleKey !(PrimArray Int)+  | ProbeChildTupleKey ![Int]++instance Eq ChildTupleKey where+  left == right =+    compare left right == EQ++instance Ord ChildTupleKey where+  compare left right =+    case (left, right) of+      (StoredChildTupleKey leftChildren, StoredChildTupleKey rightChildren) ->+        compare leftChildren rightChildren+      (ProbeChildTupleKey leftChildren, ProbeChildTupleKey rightChildren) ->+        compare leftChildren rightChildren+      (ProbeChildTupleKey probeChildren, StoredChildTupleKey storedChildren) ->+        compareChildTupleProbe probeChildren storedChildren+      (StoredChildTupleKey storedChildren, ProbeChildTupleKey probeChildren) ->+        reverseOrdering (compareChildTupleProbe probeChildren storedChildren)++compareChildTupleProbe :: [Int] -> PrimArray Int -> Ordering+compareChildTupleProbe probeChildren storedChildren =+  compareAt 0 probeChildren+  where+    storedChildCount =+      PrimArray.sizeofPrimArray storedChildren+    compareAt !childIndex remainingProbeChildren =+      case remainingProbeChildren of+        []+          | childIndex == storedChildCount -> EQ+          | otherwise -> LT+        probeChild : restProbeChildren+          | childIndex == storedChildCount -> GT+          | otherwise ->+              case compare probeChild (PrimArray.indexPrimArray storedChildren childIndex) of+                EQ -> compareAt (childIndex + 1) restProbeChildren+                ordering -> ordering+{-# INLINE compareChildTupleProbe #-}++reverseOrdering :: Ordering -> Ordering+reverseOrdering ordering =+  case ordering of+    LT -> GT+    EQ -> EQ+    GT -> LT+{-# INLINE reverseOrdering #-}++type ExactIndex :: Type+type ExactIndex = ChildTupleIndex++type ExactResultIndex :: Type+type ExactResultIndex = ChildTupleIndex++type ResultIndex :: Type+type ResultIndex = IntMap IntSet++type ChildColumnValueIndex :: Type+data ChildColumnValueIndex+  = NullaryChildColumnValueIndex+  | UnaryChildColumnValueIndex !(IntMap IntSet)+  | BinaryChildColumnValueIndex !(IntMap IntSet) !(IntMap IntSet)+  | NaryChildColumnValueIndex !(SmallArray (IntMap IntSet))++-- | One sealed, fixed-arity column section. All arrays have the same row+-- count; the child-column count is the owning operator's arity.+type OperatorRowChunk :: Type+data OperatorRowChunk = OperatorRowChunk+  { chunkResults :: !(PrimArray Int),+    chunkChildren :: !(SmallArray (PrimArray Int))+  }++-- | The sole physical row authority for one operator. Sealed chunks own the+-- fixed-capacity prefix, the bounded pending sequence owns the suffix, and+-- tombstones remove ids from their union without shifting snapshot rows.+type OperatorRowStore :: Type+data OperatorRowStore = OperatorRowStore+  { sealedRowChunks :: !(Seq OperatorRowChunk),+    pendingStoredRows :: !(Seq DatabaseRow),+    tombstonedRowIds :: !IntSet+  }++type OperatorTable :: (Type -> Type) -> Type+data OperatorTable f = OperatorTable+  { opShape :: !(f ()),+    opArity :: !Int,+    rowStore :: !OperatorRowStore,+    nextRowId :: !Int,+    -- Rows below this watermark are reflected in the derived indices; rows at+    -- or above it live only in rowStore and exactResultIx. This is private+    -- index-refresh bookkeeping, not the public commit frontier.+    derivedIndexWatermark :: !Int,+    resultIx :: !ResultIndex,+    childColumnIx :: !ChildColumnValueIndex,+    exactIx :: !ExactIndex,+    exactResultIx :: !ExactResultIndex,+    childUserIx :: !ChildUserIndex+  }++type Database :: (Type -> Type) -> Type -> Type+data Database f key = Database+  { operatorIds :: !(Map (Operator f) Int),+    operatorShapes :: !(IntMap (Operator f)),+    nextOperatorId :: !Int,+    operatorTables :: !(IntMap (OperatorTable f)),+    arrangements :: !ArrangementCache+  }+type role Database nominal nominal++type DatabaseEditor :: Type -> (Type -> Type) -> Type -> Type+data DatabaseEditor s f key = DatabaseEditor+  { workingRef :: !(STRef s (Database f key)),+    residualCommandsRef :: !(STRef s [TermCommand f key]),+    controlRef :: !(STRef s DatabaseTransactionControl)+  }++type DatabaseTransactionControl :: Type+data DatabaseTransactionControl+  = CommitDatabaseTransaction+  | AbortDatabaseTransaction+  deriving stock (Eq, Show)++type TupleLookup :: Type -> Type+data TupleLookup key+  = TupleMissing+  | TupleUnique !key+  | TupleAmbiguous !(NonEmpty key)+  deriving stock (Eq, Show)++emptyDatabase :: Database f key+emptyDatabase =+  Database+    { operatorIds = Map.empty,+      operatorShapes = IntMap.empty,+      nextOperatorId = 0,+      operatorTables = IntMap.empty,+      arrangements = IntMap.empty+    }++operatorIdFor :: (forall a. Ord a => Ord (f a)) => Operator f -> Database f key -> Maybe Int+operatorIdFor operator =+  Map.lookup operator . operatorIds+{-# INLINE operatorIdFor #-}++mapRowKeys :: (Int -> Int) -> DatabaseRow -> DatabaseRow+mapRowKeys canonicalizeKey row =+  DatabaseRow+    { rowResult = canonicalizeKey (rowResult row),+      rowChildrenArray = PrimArray.mapPrimArray canonicalizeKey (rowChildrenArray row)+    }+smallArrayToList :: SmallArray value -> [value]+smallArrayToList values =+  fmap (SmallArray.indexSmallArray values) [0 .. SmallArray.sizeofSmallArray values - 1]+{-# INLINE smallArrayToList #-}
+ test/aggregate/Main.hs view
@@ -0,0 +1,22 @@+module Main where++import qualified BasisTests+import qualified NumericTests+import qualified PublicSurfaceSpec+import qualified SolverTests+import qualified SyntaxTests+import Test.Tasty (defaultMain, testGroup)+import qualified TermTests++main :: IO ()+main =+  defaultMain $+    testGroup+      "moonlight-core"+      [ BasisTests.tests,+        NumericTests.tests,+        SyntaxTests.tests,+        SolverTests.tests,+        TermTests.tests,+        PublicSurfaceSpec.tests+      ]
+ test/basis/BasisTests.hs view
@@ -0,0 +1,42 @@+module BasisTests+  ( tests,+  )+where++import qualified BoundarySpec as BoundarySpec+import qualified CardinalitySpec as CardinalitySpec+import qualified DenseKeySpec as DenseKeySpec+import qualified FiniteSpec as FiniteSpec+import qualified IsoNormSpec as IsoNormSpec+import qualified MapAccumSpec as MapAccumSpec+import qualified OrdCollectionSpec as OrdCollectionSpec+import qualified OrderSpec as OrderSpec+import qualified ProofManifestSpec as ProofManifestSpec+import qualified QueueSpec as QueueSpec+import qualified RelationalSpec as RelationalSpec+import qualified StableHashSpec as StableHashSpec+import qualified TotalRegistrySpec as TotalRegistrySpec+import qualified TypeLevelSpec as TypeLevelSpec+import qualified ValidationSpec as ValidationSpec+import Test.Tasty (TestTree, testGroup)++tests :: TestTree+tests =+  testGroup+    "moonlight-core-basis"+    [ BoundarySpec.tests,+      CardinalitySpec.tests,+      DenseKeySpec.tests,+      FiniteSpec.tests,+      IsoNormSpec.tests,+      MapAccumSpec.tests,+      OrdCollectionSpec.tests,+      OrderSpec.tests,+      ProofManifestSpec.tests,+      QueueSpec.tests,+      RelationalSpec.tests,+      StableHashSpec.tests,+      TotalRegistrySpec.tests,+      TypeLevelSpec.tests,+      ValidationSpec.tests+    ]
+ test/basis/BoundarySpec.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeFamilies #-}++module BoundarySpec (tests) where++import Data.Set (Set)+import Data.Set qualified as Set+import Moonlight.Core (BoundaryOps (..))+import Moonlight.Core (IsLawName (..), constructorLawName)+import LawProperty (lawProperty)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck+  ( Arbitrary (..),+    Gen,+    Property,+    chooseInt,+    counterexample,+    listOf,+    property,+    (===),+    (.&&.),+  )++newtype BoundaryProbe = BoundaryProbe (Set Int)+  deriving stock (Eq, Ord, Show)++instance Arbitrary BoundaryProbe where+  arbitrary =+    BoundaryProbe . Set.fromList <$> listOf boundaryPoint++data BoundaryLaw+  = BoundaryOverlapCommutative+  | BoundaryRestrictionGluing+  | BoundaryRestrictionSubsumedByOperands+  | BoundaryCompatibilityAgreesWithOverlap+  | BoundarySubsumptionPartialOrder+  | BoundarySubsumptionOverlapIdentity+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance IsLawName BoundaryLaw where+  lawNameText =+    constructorLawName . show++instance BoundaryOps BoundaryProbe where+  type BoundaryOverlap BoundaryProbe = BoundaryProbe++  overlapBetweenBoundary (BoundaryProbe left) (BoundaryProbe right) =+    BoundaryProbe (Set.intersection left right)++  restrictBoundaryRaw (BoundaryProbe overlap) (BoundaryProbe boundary) =+    BoundaryProbe (Set.intersection overlap boundary)++  compatibleBoundaryRaw left right =+    let overlap =+          overlapBetweenBoundary left right+     in if boundaryProbeNull overlap+          then Left overlap+          else Right overlap++  subsumesBoundaryRaw (BoundaryProbe superset) (BoundaryProbe subset) =+    subset `Set.isSubsetOf` superset++tests :: TestTree+tests =+  testGroup+    "Boundary"+    [ lawProperty BoundaryOverlapCommutative propOverlapCommutative,+      lawProperty BoundaryRestrictionGluing propRestrictionGluing,+      lawProperty BoundaryRestrictionSubsumedByOperands propRestrictionSubsumedByOperands,+      lawProperty BoundaryCompatibilityAgreesWithOverlap propCompatibilityAgreesWithOverlap,+      lawProperty BoundarySubsumptionPartialOrder propSubsumptionPartialOrder,+      lawProperty BoundarySubsumptionOverlapIdentity propSubsumptionOverlapIdentity+    ]++boundaryPoint :: Gen Int+boundaryPoint =+  chooseInt (-64, 64)++boundaryProbeNull :: BoundaryProbe -> Bool+boundaryProbeNull (BoundaryProbe points) =+  Set.null points++propOverlapCommutative :: BoundaryProbe -> BoundaryProbe -> Property+propOverlapCommutative left right =+  overlapBetweenBoundary left right === overlapBetweenBoundary right left++propRestrictionGluing :: BoundaryProbe -> BoundaryProbe -> Property+propRestrictionGluing left right =+  let overlap =+        overlapBetweenBoundary left right+   in (restrictBoundaryRaw overlap left, restrictBoundaryRaw overlap right)+        === (overlap, overlap)++propRestrictionSubsumedByOperands :: BoundaryProbe -> BoundaryProbe -> Property+propRestrictionSubsumedByOperands left right =+  let restricted =+        restrictBoundaryRaw (overlapBetweenBoundary left right) left+   in property (subsumesBoundaryRaw left restricted)+        .&&. property (subsumesBoundaryRaw right restricted)++propCompatibilityAgreesWithOverlap :: BoundaryProbe -> BoundaryProbe -> Property+propCompatibilityAgreesWithOverlap left right =+  compatibleBoundaryRaw left right === expectedCompatibility left right++propSubsumptionPartialOrder :: BoundaryProbe -> BoundaryProbe -> BoundaryProbe -> Property+propSubsumptionPartialOrder left middle right =+  property (subsumesBoundaryRaw left left)+    .&&. counterexample "subsumption is not antisymmetric" antisymmetric+    .&&. counterexample "subsumption is not transitive" transitive+  where+    antisymmetric =+      not (subsumesBoundaryRaw left middle && subsumesBoundaryRaw middle left)+        || left == middle+    transitive =+      not (subsumesBoundaryRaw left middle && subsumesBoundaryRaw middle right)+        || subsumesBoundaryRaw left right++propSubsumptionOverlapIdentity :: BoundaryProbe -> BoundaryProbe -> Property+propSubsumptionOverlapIdentity superset subset =+  counterexample "subsumed boundary is not recovered as overlap" $+    not (subsumesBoundaryRaw superset subset)+      || overlapBetweenBoundary superset subset == subset++expectedCompatibility :: BoundaryProbe -> BoundaryProbe -> Either BoundaryProbe BoundaryProbe+expectedCompatibility left right =+  let overlap =+        overlapBetweenBoundary left right+   in if boundaryProbeNull overlap+        then Left overlap+        else Right overlap
+ test/basis/CardinalitySpec.hs view
@@ -0,0 +1,38 @@+module CardinalitySpec (tests) where++import Moonlight.Core+  ( CardinalityFailure (..),+    checkedNaturalToInt,+    checkedNonNegativeProduct,+    checkedNonNegativeSum,+  )+import Numeric.Natural (Natural)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)++tests :: TestTree+tests =+  testGroup+    "checked cardinality"+    [ testCase "preserves zero-factor products" $+        checkedNonNegativeProduct 0 maxBound @?= Right 0,+      testCase "accepts the largest representable product" $+        checkedNonNegativeProduct 1 maxBound @?= Right maxBound,+      testCase "rejects a product beyond maxBound" $+        checkedNonNegativeProduct 2 maxBound+          @?= Left (CardinalityProductExceedsIntRange 2 maxBound),+      testCase "rejects the 2^32 by 2^32 wraparound shape" $+        let dimension = 2 ^ (32 :: Int)+         in checkedNonNegativeProduct dimension dimension+              @?= Left (CardinalityProductExceedsIntRange dimension dimension),+      testCase "rejects negative factors before multiplication" $+        checkedNonNegativeProduct (-1) 0+          @?= Left (NegativeCardinalityFactor (-1)),+      testCase "checks workspace sums" $+        checkedNonNegativeSum maxBound 1+          @?= Left (CardinalitySumExceedsIntRange maxBound 1),+      testCase "rejects Natural cardinality beyond Int" $+        let oversized = fromIntegral (maxBound :: Int) + 1 :: Natural+         in checkedNaturalToInt oversized+              @?= Left (NaturalCardinalityExceedsIntRange oversized)+    ]
+ test/basis/DenseKeySpec.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeApplications #-}++module DenseKeySpec (tests) where++import Moonlight.Core (DenseKey (..))+import Moonlight.Core (IsLawName (..), constructorLawName)+import LawProperty (lawProperty)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (Property, (===))++data DenseKeyLaw+  = DenseKeyIntDecodeEncodeRoundTrip+  | DenseKeyIntEncodeDecodeRoundTrip+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance IsLawName DenseKeyLaw where+  lawNameText =+    constructorLawName . show++tests :: TestTree+tests =+  testGroup+    "DenseKey"+    [ lawProperty DenseKeyIntDecodeEncodeRoundTrip propIntDecodeEncodeRoundTrip,+      lawProperty DenseKeyIntEncodeDecodeRoundTrip propIntEncodeDecodeRoundTrip+    ]++propIntDecodeEncodeRoundTrip :: Int -> Property+propIntDecodeEncodeRoundTrip value =+  decodeDenseKey @Int (encodeDenseKey value) === value++propIntEncodeDecodeRoundTrip :: Int -> Property+propIntEncodeDecodeRoundTrip denseKey =+  encodeDenseKey (decodeDenseKey @Int denseKey) === denseKey
+ test/basis/FiniteSpec.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module FiniteSpec (tests) where++import Data.List.NonEmpty (NonEmpty (..))+import Data.Set qualified as Set+import Moonlight.Core+  ( FiniteUniverse (..),+    boundedEnumUniverse,+    finiteUniverseList,+    finiteUniverseSet,+  )+import Moonlight.Core (IsLawName (..), constructorLawName)+import LawProperty (lawProperty)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (Property, (===))++data FiniteBit+  = FiniteOff+  | FiniteOn+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance FiniteUniverse FiniteBit where+  finiteUniverse =+    boundedEnumUniverse++data FiniteTriad+  = FiniteAlpha+  | FiniteBeta+  | FiniteGamma+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance FiniteUniverse FiniteTriad where+  finiteUniverse =+    FiniteAlpha :| [FiniteBeta, FiniteGamma]++data FiniteLaw+  = FiniteUniverseListExhaustive+  | FiniteUniverseListDuplicateFree+  | FiniteUniverseSetCoherent+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance IsLawName FiniteLaw where+  lawNameText =+    constructorLawName . show++tests :: TestTree+tests =+  testGroup+    "Finite"+    [ testGroup+        "FiniteBit"+        [ lawProperty FiniteUniverseListExhaustive (propFiniteUniverseListExhaustive @FiniteBit),+          lawProperty FiniteUniverseListDuplicateFree (propFiniteUniverseListDuplicateFree @FiniteBit),+          lawProperty FiniteUniverseSetCoherent (propFiniteUniverseSetCoherent @FiniteBit)+        ],+      testGroup+        "FiniteTriad"+        [ lawProperty FiniteUniverseListExhaustive (propFiniteUniverseListExhaustive @FiniteTriad),+          lawProperty FiniteUniverseListDuplicateFree (propFiniteUniverseListDuplicateFree @FiniteTriad),+          lawProperty FiniteUniverseSetCoherent (propFiniteUniverseSetCoherent @FiniteTriad)+        ]+    ]++propFiniteUniverseListExhaustive ::+  forall value.+  (Bounded value, Enum value, Eq value, FiniteUniverse value, Show value) =>+  Property+propFiniteUniverseListExhaustive =+  finiteUniverseList @value === enumFromTo minBound maxBound++propFiniteUniverseListDuplicateFree ::+  forall value.+  (FiniteUniverse value, Ord value) =>+  Property+propFiniteUniverseListDuplicateFree =+  length (finiteUniverseList @value) === Set.size (finiteUniverseSet @value)++propFiniteUniverseSetCoherent ::+  forall value.+  (FiniteUniverse value, Ord value, Show value) =>+  Property+propFiniteUniverseSetCoherent =+  finiteUniverseSet @value === Set.fromList (finiteUniverseList @value)
+ test/basis/IsoNormSpec.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module IsoNormSpec (tests) where++import Moonlight.Core (IsoNorm (..), isoNormalize)+import Moonlight.Core (IsLawName (..), constructorLawName)+import LawProperty (lawProperty)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (Arbitrary (..), Property, (===))++newtype IsoProbe = IsoProbe (Int, Bool)+  deriving stock (Eq, Show)++type IsoProbeRep = (Bool, Int)++instance IsoNorm IsoProbe IsoProbeRep where+  isoFrom (flag, value) =+    IsoProbe (value, flag)++  isoTo (IsoProbe (value, flag)) =+    (flag, value)++instance Arbitrary IsoProbe where+  arbitrary =+    IsoProbe <$> arbitrary++data IsoNormLaw+  = IsoNormFromToRoundTrip+  | IsoNormToFromRoundTrip+  | IsoNormNormalizeIdempotent+  | IsoNormNormalizeIdentity+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance IsLawName IsoNormLaw where+  lawNameText =+    constructorLawName . show++tests :: TestTree+tests =+  testGroup+    "IsoNorm"+    [ lawProperty IsoNormFromToRoundTrip propFromToRoundTrip,+      lawProperty IsoNormToFromRoundTrip propToFromRoundTrip,+      lawProperty IsoNormNormalizeIdempotent propNormalizeIdempotent,+      lawProperty IsoNormNormalizeIdentity propNormalizeIdentity+    ]++propFromToRoundTrip :: IsoProbe -> Property+propFromToRoundTrip wrapped =+  isoFrom (isoTo wrapped) === wrapped++propToFromRoundTrip :: IsoProbeRep -> Property+propToFromRoundTrip representation =+  isoTo (isoFrom representation :: IsoProbe) === representation++propNormalizeIdempotent :: IsoProbe -> Property+propNormalizeIdempotent wrapped =+  isoNormalize (isoNormalize wrapped) === isoNormalize wrapped++propNormalizeIdentity :: IsoProbe -> Property+propNormalizeIdentity wrapped =+  isoNormalize wrapped === wrapped
+ test/basis/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import qualified BasisTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain BasisTests.tests
+ test/basis/MapAccumSpec.hs view
@@ -0,0 +1,34 @@+module MapAccumSpec (tests) where++import Data.Map.Strict qualified as Map+import Moonlight.Core (accumByKey, buildTripleIndex, indexMap)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)++tests :: TestTree+tests =+  testGroup+    "MapAccum"+    [ testCase "accumByKey preserves input order for noncommutative semigroups" $+        accumByKey fst (pure . snd) [('a', "first"), ('a', "second"), ('b', "only")]+          @?= Map.fromList [('a', ["first", "second"]), ('b', ["only"])],+      testCase "indexMap records the last index for duplicate keys" $+        indexMap ["alpha", "beta", "alpha", "gamma", "beta"]+          @?= Map.fromList [("alpha", 2), ("beta", 4), ("gamma", 3)],+      testCase "buildTripleIndex preserves per-key input order" $+        let values =+              [ ('a', "left", 1 :: Int),+                ('a', "right", 2),+                ('b', "left", 1),+                ('a', "left", 3)+              ]+         in buildTripleIndex+              (\(firstKey, _secondKey, _thirdKey) -> firstKey)+              (\(_firstKey, secondKey, _thirdKey) -> secondKey)+              (\(_firstKey, _secondKey, thirdKey) -> thirdKey)+              values+              @?= ( Map.fromList [('a', [('a', "left", 1), ('a', "right", 2), ('a', "left", 3)]), ('b', [('b', "left", 1)])],+                    Map.fromList [("left", [('a', "left", 1), ('b', "left", 1), ('a', "left", 3)]), ("right", [('a', "right", 2)])],+                    Map.fromList [(1, [('a', "left", 1), ('b', "left", 1)]), (2, [('a', "right", 2)]), (3, [('a', "left", 3)])]+                  )+    ]
+ test/basis/OrdCollectionSpec.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module OrdCollectionSpec (tests) where++import Data.IntMap.Strict (IntMap)+import Data.IntSet (IntSet)+import Data.Map.Strict (Map)+import Data.Set (Set)+import Moonlight.Core (IsLawName (..), constructorLawName)+import Moonlight.Core (OrdMap (..), OrdSet (..))+import LawProperty (lawProperty)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (Arbitrary, Property, (===), (.&&.))++data OrdCollectionLaw+  = OrdSetUnionIdentity+  | OrdSetUnionAssociative+  | OrdSetIntersectionAbsorption+  | OrdSetDifferencePartition+  | OrdSetMembershipCoherent+  | OrdSetUnionsCoherent+  | OrdSetProjectionSizeCoherent+  | OrdMapProjectionRoundTrip+  | OrdMapInsertLookup+  | OrdMapInsertWithAccumulates+  | OrdMapDeleteRemoves+  | OrdMapUnionWithAssociative+  | OrdMapUnionWithCommutativeForCommutativeCombine+  | OrdMapFromListWithAccumulates+  | OrdMapProjectionSizeCoherent+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance IsLawName OrdCollectionLaw where+  lawNameText =+    constructorLawName . show++tests :: TestTree+tests =+  testGroup+    "OrdCollection"+    [ testGroup "IntSet" (ordSetLaws @IntSet),+      testGroup "Set Int" (ordSetLaws @(Set Int)),+      testGroup "IntMap Int" (ordMapLaws @(IntMap Int)),+      testGroup "Map Int Int" (ordMapLaws @(Map Int Int))+    ]++ordSetLaws ::+  forall set.+  ( Arbitrary (SetKey set),+    Eq set,+    Eq (SetKey set),+    OrdSet set,+    Show set,+    Show (SetKey set)+  ) =>+  [TestTree]+ordSetLaws =+  [ lawProperty OrdSetUnionIdentity (propOrdSetUnionIdentity @set),+    lawProperty OrdSetUnionAssociative (propOrdSetUnionAssociative @set),+    lawProperty OrdSetIntersectionAbsorption (propOrdSetIntersectionAbsorption @set),+    lawProperty OrdSetDifferencePartition (propOrdSetDifferencePartition @set),+    lawProperty OrdSetMembershipCoherent (propOrdSetMembershipCoherent @set),+    lawProperty OrdSetUnionsCoherent (propOrdSetUnionsCoherent @set),+    lawProperty OrdSetProjectionSizeCoherent (propOrdSetProjectionSizeCoherent @set)+  ]++ordMapLaws ::+  forall map.+  ( Eq map,+    Eq (MapKey map),+    Eq (MapValue map),+    Arbitrary (MapKey map),+    Arbitrary (MapValue map),+    Num (MapValue map),+    OrdMap map,+    Show map,+    Show (MapKey map),+    Show (MapValue map)+  ) =>+  [TestTree]+ordMapLaws =+  [ lawProperty OrdMapProjectionRoundTrip (propOrdMapProjectionRoundTrip @map),+    lawProperty OrdMapInsertLookup (propOrdMapInsertLookup @map),+    lawProperty OrdMapInsertWithAccumulates (propOrdMapInsertWithAccumulates @map),+    lawProperty OrdMapDeleteRemoves (propOrdMapDeleteRemoves @map),+    lawProperty OrdMapUnionWithAssociative (propOrdMapUnionWithAssociative @map),+    lawProperty OrdMapUnionWithCommutativeForCommutativeCombine (propOrdMapUnionWithCommutative @map),+    lawProperty OrdMapFromListWithAccumulates (propOrdMapFromListWithAccumulates @map),+    lawProperty OrdMapProjectionSizeCoherent (propOrdMapProjectionSizeCoherent @map)+  ]++propOrdSetUnionIdentity ::+  forall set.+  (Eq set, OrdSet set, Show set) =>+  [SetKey set] ->+  Property+propOrdSetUnionIdentity values =+  unionSet emptySet setValue === setValue+    .&&. unionSet setValue emptySet === setValue+  where+    setValue =+      fromListSet values :: set++propOrdSetUnionAssociative ::+  forall set.+  (Eq set, OrdSet set, Show set) =>+  [SetKey set] ->+  [SetKey set] ->+  [SetKey set] ->+  Property+propOrdSetUnionAssociative leftValues middleValues rightValues =+  unionSet leftValue (unionSet middleValue rightValue)+    === unionSet (unionSet leftValue middleValue) rightValue+  where+    leftValue =+      fromListSet leftValues :: set+    middleValue =+      fromListSet middleValues :: set+    rightValue =+      fromListSet rightValues :: set++propOrdSetIntersectionAbsorption ::+  forall set.+  (Eq set, OrdSet set, Show set) =>+  [SetKey set] ->+  [SetKey set] ->+  Property+propOrdSetIntersectionAbsorption leftValues rightValues =+  intersectionSet leftValue (unionSet leftValue rightValue) === leftValue+  where+    leftValue =+      fromListSet leftValues :: set+    rightValue =+      fromListSet rightValues :: set++propOrdSetDifferencePartition ::+  forall set.+  (Eq set, OrdSet set, Show set) =>+  [SetKey set] ->+  [SetKey set] ->+  Property+propOrdSetDifferencePartition leftValues rightValues =+  intersectionSet (differenceSet leftValue rightValue) rightValue === emptySet+    .&&. unionSet (differenceSet leftValue rightValue) (intersectionSet leftValue rightValue) === leftValue+  where+    leftValue =+      fromListSet leftValues :: set+    rightValue =+      fromListSet rightValues :: set++propOrdSetMembershipCoherent ::+  forall set.+  (Eq (SetKey set), OrdSet set) =>+  SetKey set ->+  [SetKey set] ->+  Property+propOrdSetMembershipCoherent key values =+  memberSet key setValue === elem key (toAscListSet setValue)+  where+    setValue =+      fromListSet values :: set++propOrdSetUnionsCoherent ::+  forall set.+  (Eq set, OrdSet set, Show set) =>+  [[SetKey set]] ->+  Property+propOrdSetUnionsCoherent values =+  unionsSet setValues === foldr unionSet emptySet setValues+  where+    setValues =+      fromListSet <$> values :: [set]++propOrdSetProjectionSizeCoherent ::+  forall set.+  OrdSet set =>+  [SetKey set] ->+  Property+propOrdSetProjectionSizeCoherent values =+  sizeSet setValue === length ascendingValues+    .&&. nullSet setValue === null ascendingValues+  where+    setValue =+      fromListSet values :: set+    ascendingValues =+      toAscListSet setValue++propOrdMapProjectionRoundTrip ::+  forall map.+  (Eq map, OrdMap map, Show map) =>+  [(MapKey map, MapValue map)] ->+  Property+propOrdMapProjectionRoundTrip entries =+  fromListMap (toAscListMap mapValue) === mapValue+  where+    mapValue =+      fromListMap entries :: map++propOrdMapInsertLookup ::+  forall map.+  (Eq (MapValue map), OrdMap map, Show (MapValue map)) =>+  MapKey map ->+  MapValue map ->+  [(MapKey map, MapValue map)] ->+  Property+propOrdMapInsertLookup key value entries =+  lookupMap key (insertMap key value mapValue) === Just value+  where+    mapValue =+      fromListMap entries :: map++propOrdMapInsertWithAccumulates ::+  forall map.+  (Eq (MapValue map), Num (MapValue map), OrdMap map, Show (MapValue map)) =>+  MapKey map ->+  MapValue map ->+  MapValue map ->+  [(MapKey map, MapValue map)] ->+  Property+propOrdMapInsertWithAccumulates key newValue oldValue entries =+  lookupMap key (insertWithMap (+) key newValue seededMap) === Just (newValue + oldValue)+  where+    seededMap =+      insertMap key oldValue (fromListMap entries :: map)++propOrdMapDeleteRemoves ::+  forall map.+  (Eq (MapValue map), OrdMap map, Show (MapValue map)) =>+  MapKey map ->+  [(MapKey map, MapValue map)] ->+  Property+propOrdMapDeleteRemoves key entries =+  lookupMap key (deleteMap key mapValue) === Nothing+  where+    mapValue =+      fromListMap entries :: map++propOrdMapUnionWithAssociative ::+  forall map.+  (Eq map, Num (MapValue map), OrdMap map, Show map) =>+  [(MapKey map, MapValue map)] ->+  [(MapKey map, MapValue map)] ->+  [(MapKey map, MapValue map)] ->+  Property+propOrdMapUnionWithAssociative leftEntries middleEntries rightEntries =+  unionWithMap (+) leftValue (unionWithMap (+) middleValue rightValue)+    === unionWithMap (+) (unionWithMap (+) leftValue middleValue) rightValue+  where+    leftValue =+      fromListMap leftEntries :: map+    middleValue =+      fromListMap middleEntries :: map+    rightValue =+      fromListMap rightEntries :: map++propOrdMapUnionWithCommutative ::+  forall map.+  (Eq map, Num (MapValue map), OrdMap map, Show map) =>+  [(MapKey map, MapValue map)] ->+  [(MapKey map, MapValue map)] ->+  Property+propOrdMapUnionWithCommutative leftEntries rightEntries =+  unionWithMap (+) leftValue rightValue === unionWithMap (+) rightValue leftValue+  where+    leftValue =+      fromListMap leftEntries :: map+    rightValue =+      fromListMap rightEntries :: map++propOrdMapFromListWithAccumulates ::+  forall map.+  (Eq (MapKey map), Eq (MapValue map), Num (MapValue map), OrdMap map, Show (MapValue map)) =>+  MapKey map ->+  MapValue map ->+  MapValue map ->+  [(MapKey map, MapValue map)] ->+  Property+propOrdMapFromListWithAccumulates key leftValue rightValue entries =+  lookupMap key (fromListWithMap (+) seededEntries :: map) === Just expectedValue+  where+    seededEntries =+      (key, leftValue) : (key, rightValue) : entries+    expectedValue =+      sum (matchingValue <$> seededEntries)+    matchingValue (candidateKey, value)+      | candidateKey == key = value+      | otherwise = 0++propOrdMapProjectionSizeCoherent ::+  forall map.+  OrdMap map =>+  [(MapKey map, MapValue map)] ->+  Property+propOrdMapProjectionSizeCoherent entries =+  sizeMap mapValue === length ascendingEntries+    .&&. nullMap mapValue === null ascendingEntries+  where+    mapValue =+      fromListMap entries :: map+    ascendingEntries =+      toAscListMap mapValue
+ test/basis/OrderSpec.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeApplications #-}++module OrderSpec+  ( tests,+  )+where++import Control.Monad+  ( when,+  )+import Data.Foldable+  ( traverse_,+  )+import Data.Set qualified as Set+import Moonlight.Core+  ( FiniteUniverse (..),+    boundedEnumUniverse,+    finiteUniverseList,+    finiteUniverseSet,+  )+import Moonlight.Core+  ( PartialOrder (..),+    comparable,+    finitePointwiseLeq,+    incomparable,+    pointwiseLeqOver,+  )+import Test.Tasty+  ( TestTree,+    testGroup,+  )+import Test.Tasty.HUnit+  ( Assertion,+    assertBool,+    testCase,+    (@?=),+  )++data TinyDomain+  = TinyA+  | TinyB+  | TinyC+  deriving stock (Eq, Ord, Show, Enum, Bounded)++instance FiniteUniverse TinyDomain where+  finiteUniverse =+    boundedEnumUniverse++tests :: TestTree+tests =+  testGroup+    "partial order"+    [ testCase "Bool satisfies the partial-order laws" $+        assertPartialOrderLaws "Bool" [False, True],+      testCase "product order satisfies the partial-order laws" $+        assertPartialOrderLaws "Bool product" boolProductSamples,+      testCase "set inclusion satisfies the partial-order laws" $+        assertPartialOrderLaws "Set Int" setSamples,+      testCase "strict order is non-equal less-or-equal" testStrictOrder,+      testCase "product order is pointwise and admits incomparable points" testProductOrder,+      testCase "finite pointwise order quantifies over the finite universe" testFinitePointwiseOrder+    ]++assertPartialOrderLaws ::+  (PartialOrder order, Show order) =>+  String ->+  [order] ->+  Assertion+assertPartialOrderLaws label values = do+  traverse_ (assertReflexive label) values+  traverse_ (uncurry (assertAntisymmetric label)) (pairs values)+  traverse_ (assertTransitive label) (triples values)++assertReflexive ::+  (PartialOrder order, Show order) =>+  String ->+  order ->+  Assertion+assertReflexive label value =+  assertBool+    (label <> " is not reflexive at " <> show value)+    (leq value value)++assertAntisymmetric ::+  (PartialOrder order, Show order) =>+  String ->+  order ->+  order ->+  Assertion+assertAntisymmetric label left right =+  when (leq left right && leq right left) $+    assertBool+      ( label+          <> " violates antisymmetry at "+          <> show (left, right)+      )+      (left == right)++assertTransitive ::+  (PartialOrder order, Show order) =>+  String ->+  (order, order, order) ->+  Assertion+assertTransitive label (left, middle, right) =+  when (leq left middle && leq middle right) $+    assertBool+      ( label+          <> " is not transitive at "+          <> show (left, middle, right)+      )+      (leq left right)++testStrictOrder :: Assertion+testStrictOrder = do+  lt False True @?= True+  lt True True @?= False+  lt True False @?= False++testProductOrder :: Assertion+testProductOrder = do+  leq (False, True) (True, True) @?= True+  leq (False, True) (True, False) @?= False+  comparable (False, True) (True, True) @?= True+  incomparable (False, True) (True, False) @?= True++testFinitePointwiseOrder :: Assertion+testFinitePointwiseOrder = do+  finiteUniverseList @TinyDomain @?= [TinyA, TinyB, TinyC]+  finiteUniverseSet @TinyDomain @?= Set.fromList [TinyA, TinyB, TinyC]+  pointwiseLeqOver [TinyA, TinyC] leftProjection rightProjection @?= True+  finitePointwiseLeq leftProjection rightProjection @?= False+  finitePointwiseLeq (const False) rightProjection @?= True++leftProjection :: TinyDomain -> Bool+leftProjection TinyA =+  True+leftProjection TinyB =+  True+leftProjection TinyC =+  False++rightProjection :: TinyDomain -> Bool+rightProjection TinyA =+  True+rightProjection TinyB =+  False+rightProjection TinyC =+  False++boolProductSamples :: [(Bool, Bool)]+boolProductSamples =+  (,) <$> [False, True] <*> [False, True]++setSamples :: [Set.Set Int]+setSamples =+  Set.fromList+    <$> [ [],+          [1],+          [2],+          [1, 2],+          [1, 2, 3]+        ]++pairs :: [a] -> [(a, a)]+pairs values =+  (,) <$> values <*> values++triples :: [a] -> [(a, a, a)]+triples values =+  (,,) <$> values <*> values <*> values
+ test/basis/ProofManifestSpec.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP #-}++module ProofManifestSpec (tests) where++import Moonlight.Core+  ( ProofManifestError (..),+    parseTheoremManifestNames+  )+import SourceShape (assertSourceShape)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)++tests :: TestTree+tests =+  testGroup+    "ProofManifest"+    [ testCase "parser accepts the compact canonical manifest shape" testParseCanonicalManifest,+      testCase "parser rejects malformed manifest payloads" testRejectMalformedManifest,+      testCase "parser rejects non-JSON string escapes" testRejectNonJsonStrings,+      testCase "proof manifest codec stays parser-backed and normalized" testProofManifestBoundaryShape+    ]++testParseCanonicalManifest :: IO ()+testParseCanonicalManifest = do+  parseTheoremManifestNames "  {\"theorems\":[\"alpha\",\"beta.gamma\"]}\n"+    @?= Right ["alpha", "beta.gamma"]+  parseTheoremManifestNames "{\"theorems\": [\"alpha\"]}"+    @?= Right ["alpha"]++testRejectMalformedManifest :: IO ()+testRejectMalformedManifest = do+  parseTheoremManifestNames "{\"theorems\":[alpha]}"+    @?= Left ProofManifestParseFailure+  parseTheoremManifestNames "{\"laws\":[\"alpha\"]}"+    @?= Left ProofManifestParseFailure+  parseTheoremManifestNames "{\"theorems\":[\"\"]}"+    @?= Left EmptyTheoremManifestName+  parseTheoremManifestNames "{\"theorems\":[\" alpha\"]}"+    @?= Left (WhitespacePaddedTheoremManifestName " alpha")+  parseTheoremManifestNames "{\"theorems\":[\"alpha\",\"alpha\"]}"+    @?= Left (DuplicateTheoremManifestName "alpha")++testRejectNonJsonStrings :: IO ()+testRejectNonJsonStrings = do+  parseTheoremManifestNames "{\"theorems\":[\"alpha\nbeta\"]}"+    @?= Left ProofManifestParseFailure+  parseTheoremManifestNames "{\"theorems\":[\"\\uD800\"]}"+    @?= Left ProofManifestParseFailure++testProofManifestBoundaryShape :: IO ()+testProofManifestBoundaryShape =+  assertSourceShape+    __FILE__+    "src-basis/Moonlight/Core/ProofManifest.hs"+    [ "renderTheoremManifestJson theoremIdentifiers =",+      "intercalate \",\" (map quoteJsonString (canonicalTheoremManifestNames theoremIdentifiers))",+      "parseTheoremManifestNames source =",+      "parseManifestJson source >>= validateTheoremManifestNames",+      "validateTheoremManifestNames",+      "parseManifestJson source",+      "Set.toAscList . Set.fromList",+      "duplicateTheoremName =",+      "firstDuplicate",+      "unicodeEscapeParser"+    ]+    [ "maybe [] id (parseManifestJson source)",+      "last parses"+    ]
+ test/basis/QueueSpec.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DerivingStrategies #-}++module QueueSpec (tests) where++import Moonlight.Core (IsLawName (..), constructorLawName)+import Moonlight.Core+  ( dequeue,+    emptyQueue,+    enqueue,+    enqueueAll,+    queueFromList,+    queueNull,+    queueToList,+  )+import LawProperty (lawProperty)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (Property, (===), (.&&.))++data QueueLaw+  = QueueProjectionRoundTrip+  | QueueEnqueuePreservesTailOrder+  | QueueEnqueueAllPreservesInputOrder+  | QueueDequeuePreservesFifoOrder+  | QueueNullCoherentWithProjection+  | QueueDequeueSizeCoherent+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance IsLawName QueueLaw where+  lawNameText =+    constructorLawName . show++tests :: TestTree+tests =+  testGroup+    "Queue"+    [ lawProperty QueueProjectionRoundTrip propProjectionRoundTrip,+      lawProperty QueueEnqueuePreservesTailOrder propEnqueuePreservesTailOrder,+      lawProperty QueueEnqueueAllPreservesInputOrder propEnqueueAllPreservesInputOrder,+      lawProperty QueueDequeuePreservesFifoOrder propDequeuePreservesFifoOrder,+      lawProperty QueueNullCoherentWithProjection propNullCoherentWithProjection,+      lawProperty QueueDequeueSizeCoherent propDequeueSizeCoherent+    ]++propProjectionRoundTrip :: [Int] -> Property+propProjectionRoundTrip values =+  queueToList (queueFromList values) === values++propEnqueuePreservesTailOrder :: Int -> [Int] -> Property+propEnqueuePreservesTailOrder value values =+  queueToList (enqueue value (queueFromList values)) === values <> [value]++propEnqueueAllPreservesInputOrder :: [Int] -> [Int] -> Property+propEnqueueAllPreservesInputOrder appendedValues initialValues =+  queueToList (enqueueAll appendedValues (queueFromList initialValues))+    === initialValues <> appendedValues++propDequeuePreservesFifoOrder :: [Int] -> Property+propDequeuePreservesFifoOrder values =+  case values of+    [] ->+      dequeue (queueFromList values) === Nothing+    first : rest ->+      dequeue (queueFromList values) === Just (first, queueFromList rest)++propNullCoherentWithProjection :: [Int] -> Property+propNullCoherentWithProjection values =+  queueNull queue === null values+    .&&. queueNull emptyQueue === True+  where+    queue =+      queueFromList values++propDequeueSizeCoherent :: [Int] -> Property+propDequeueSizeCoherent values =+  case dequeue (queueFromList values) of+    Nothing ->+      length values === 0+    Just (_, restQueue) ->+      length (queueToList restQueue) === length values - 1
+ test/basis/RelationalSpec.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE DerivingStrategies #-}++module RelationalSpec (tests) where++import Moonlight.Core (IsLawName (..), constructorLawName)+import Moonlight.Core (PartialOrder (..))+import Moonlight.Core+  ( atomIdKey,+    initialLiveEpoch,+    initialQuotientEpoch,+    liveEpochKey,+    mkAtomId,+    mkLiveEpoch,+    mkQueryId,+    mkQuotientEpoch,+    mkSlotId,+    nextLiveEpoch,+    nextQuotientEpoch,+    queryIdKey,+    quotientEpochKey,+    slotIdKey,+  )+import LawProperty (lawProperty)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck+  ( Arbitrary (..),+    Gen,+    Property,+    counterexample,+    elements,+    frequency,+    property,+    (===),+    (==>),+    (.&&.),+  )++newtype EpochKey = EpochKey Int+  deriving stock (Eq, Show)++instance Arbitrary EpochKey where+  arbitrary =+    EpochKey <$> epochKey++  shrink (EpochKey value) =+    EpochKey <$> shrink value++data RelationalLaw+  = RelationalQueryIdKeyRoundTrip+  | RelationalAtomIdKeyRoundTrip+  | RelationalSlotIdKeyRoundTrip+  | RelationalQuotientEpochKeyRoundTrip+  | RelationalLiveEpochKeyRoundTrip+  | RelationalQuotientEpochInitialKey+  | RelationalLiveEpochInitialKey+  | RelationalQuotientEpochNextKeySuccessor+  | RelationalLiveEpochNextKeySuccessor+  | RelationalQuotientEpochNextMaxBoundCeiling+  | RelationalLiveEpochNextMaxBoundCeiling+  | RelationalQuotientEpochNextMonotoneBelowCeiling+  | RelationalLiveEpochNextMonotoneBelowCeiling+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance IsLawName RelationalLaw where+  lawNameText =+    constructorLawName . show++tests :: TestTree+tests =+  testGroup+    "Relational"+    [ lawProperty RelationalQueryIdKeyRoundTrip propQueryIdKeyRoundTrip,+      lawProperty RelationalAtomIdKeyRoundTrip propAtomIdKeyRoundTrip,+      lawProperty RelationalSlotIdKeyRoundTrip propSlotIdKeyRoundTrip,+      lawProperty RelationalQuotientEpochKeyRoundTrip propQuotientEpochKeyRoundTrip,+      lawProperty RelationalLiveEpochKeyRoundTrip propLiveEpochKeyRoundTrip,+      lawProperty RelationalQuotientEpochInitialKey propQuotientEpochInitialKey,+      lawProperty RelationalLiveEpochInitialKey propLiveEpochInitialKey,+      lawProperty RelationalQuotientEpochNextKeySuccessor propQuotientEpochNextKeySuccessor,+      lawProperty RelationalLiveEpochNextKeySuccessor propLiveEpochNextKeySuccessor,+      lawProperty RelationalQuotientEpochNextMaxBoundCeiling propQuotientEpochNextMaxBoundCeiling,+      lawProperty RelationalLiveEpochNextMaxBoundCeiling propLiveEpochNextMaxBoundCeiling,+      lawProperty RelationalQuotientEpochNextMonotoneBelowCeiling propQuotientEpochNextMonotoneBelowCeiling,+      lawProperty RelationalLiveEpochNextMonotoneBelowCeiling propLiveEpochNextMonotoneBelowCeiling+    ]++epochKey :: Gen Int+epochKey =+  frequency+    [ (8, elements [maxBound]),+      (3, elements [minBound, -1, 0, 1, maxBound - 1]),+      (1, arbitrary)+    ]++propQueryIdKeyRoundTrip :: Int -> Property+propQueryIdKeyRoundTrip key =+  keyRoundTrip mkQueryId queryIdKey key++propAtomIdKeyRoundTrip :: Int -> Property+propAtomIdKeyRoundTrip key =+  keyRoundTrip mkAtomId atomIdKey key++propSlotIdKeyRoundTrip :: Int -> Property+propSlotIdKeyRoundTrip key =+  keyRoundTrip mkSlotId slotIdKey key++propQuotientEpochKeyRoundTrip :: EpochKey -> Property+propQuotientEpochKeyRoundTrip (EpochKey key) =+  keyRoundTrip mkQuotientEpoch quotientEpochKey key++propLiveEpochKeyRoundTrip :: EpochKey -> Property+propLiveEpochKeyRoundTrip (EpochKey key) =+  keyRoundTrip mkLiveEpoch liveEpochKey key++propQuotientEpochInitialKey :: Property+propQuotientEpochInitialKey =+  quotientEpochKey initialQuotientEpoch === 0++propLiveEpochInitialKey :: Property+propLiveEpochInitialKey =+  liveEpochKey initialLiveEpoch === 0++propQuotientEpochNextKeySuccessor :: EpochKey -> Property+propQuotientEpochNextKeySuccessor (EpochKey key) =+  quotientEpochKey (nextQuotientEpoch (mkQuotientEpoch key)) === successorEpochKey key++propLiveEpochNextKeySuccessor :: EpochKey -> Property+propLiveEpochNextKeySuccessor (EpochKey key) =+  liveEpochKey (nextLiveEpoch (mkLiveEpoch key)) === successorEpochKey key++propQuotientEpochNextMaxBoundCeiling :: Property+propQuotientEpochNextMaxBoundCeiling =+  quotientEpochKey (nextQuotientEpoch (mkQuotientEpoch maxBound)) === maxBound++propLiveEpochNextMaxBoundCeiling :: Property+propLiveEpochNextMaxBoundCeiling =+  liveEpochKey (nextLiveEpoch (mkLiveEpoch maxBound)) === maxBound++propQuotientEpochNextMonotoneBelowCeiling :: EpochKey -> Property+propQuotientEpochNextMonotoneBelowCeiling (EpochKey key) =+  key < maxBound ==> epochMonotone mkQuotientEpoch quotientEpochKey nextQuotientEpoch key++propLiveEpochNextMonotoneBelowCeiling :: EpochKey -> Property+propLiveEpochNextMonotoneBelowCeiling (EpochKey key) =+  key < maxBound ==> epochMonotone mkLiveEpoch liveEpochKey nextLiveEpoch key++keyRoundTrip :: (Eq identifier, Show identifier) => (Int -> identifier) -> (identifier -> Int) -> Int -> Property+keyRoundTrip construct project key =+  project identifier === key+    .&&. construct (project identifier) === identifier+  where+    identifier =+      construct key++successorEpochKey :: Int -> Int+successorEpochKey key+  | key < maxBound = key + 1+  | otherwise = maxBound++epochMonotone ::+  (PartialOrder epoch, Show epoch) =>+  (Int -> epoch) ->+  (epoch -> Int) ->+  (epoch -> epoch) ->+  Int ->+  Property+epochMonotone construct project advance key =+  counterexample monotonicityFailure $+    property (leq epochValue nextEpoch && project epochValue < project nextEpoch)+  where+    epochValue =+      construct key+    nextEpoch =+      advance epochValue+    monotonicityFailure =+      "epoch did not strictly increase from "+        <> show epochValue+        <> " to "+        <> show nextEpoch
+ test/basis/StableHashSpec.hs view
@@ -0,0 +1,139 @@+module StableHashSpec (tests) where++import qualified Data.ByteString as ByteString+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import Data.ByteString.Builder qualified as Builder+import Data.Foldable (traverse_)+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TextEncoding+import Data.Word (Word64, Word8)+import Moonlight.Core+  ( defaultStableHashKey,+    sipHashFinalize,+    sipHash24,+    sipHashDigest,+    sipHashInit,+    sipHashUpdateByteString,+    stableHashBuilder,+    stableHashByteStrings,+    stableHashEncodingByteString,+    stableHashEncodingChunks,+    stableHashEncodingDigest,+    stableHashEncodingTextUtf8,+    stableHashEncodingVersion,+    stableHashEncodingWord64Dec,+    stableHashEncodingWord64LE,+    stableHashEncodingWord8,+    unStableHashDigest,+  )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))+import Test.Tasty.QuickCheck (testProperty, (===))++tests :: TestTree+tests =+  testGroup+    "stable_hash"+    [ testCase "sipHash24 is deterministic for identical inputs" $+        sipHash24 17 23 (BS8.pack "meridian") @?= sipHash24 17 23 (BS8.pack "meridian"),+      testCase "byte framing encoding is versioned" $+        stableHashEncodingVersion @?= 2,+      testCase "byte-string chunks are deterministically framed" $+        stableHashByteStrings [BS8.pack "moon", BS8.pack "light"]+          @?= stableHashByteStrings [BS8.pack "moon", BS8.pack "light"],+      testCase "builder payloads are deterministically hashed" $+        stableHashBuilder (Builder.string8 "moonlight")+          @?= stableHashBuilder (Builder.string8 "moonlight"),+      testCase "builder streaming matches materialized versioned preimage" $+        unStableHashDigest (stableHashBuilder (Builder.string8 "moonlight" <> Builder.word64LE 42))+          @?= sipHashDigest+            defaultStableHashKey+            ( LazyByteString.toStrict+                ( Builder.toLazyByteString+                    ( Builder.word64LE stableHashEncodingVersion+                        <> Builder.string8 "moonlight"+                        <> Builder.word64LE 42+                    )+                )+            ),+      testCase "encoding writers hash without materialized builder payloads" $+        stableHashEncodingDigest+          defaultStableHashKey+          ( stableHashEncodingWord64LE stableHashEncodingVersion+              <> stableHashEncodingWord8 0x6d+              <> stableHashEncodingWord64LE 42+          )+          @?= stableHashBuilder (Builder.word8 0x6d <> Builder.word64LE 42),+      testCase "text utf8 writer matches encodeUtf8 bytes" $+        let textValue =+              Text.pack "moonλ🌙"+         in stableHashEncodingDigest+              defaultStableHashKey+              (stableHashEncodingWord64LE stableHashEncodingVersion <> stableHashEncodingTextUtf8 textValue)+              @?= stableHashBuilder (Builder.byteString (TextEncoding.encodeUtf8 textValue)),+      testProperty "word64 decimal writer matches materialized decimal bytes" $+        \(wordValue :: Word64) ->+          stableHashEncodingDigest+            defaultStableHashKey+            (stableHashEncodingWord64LE stableHashEncodingVersion <> stableHashEncodingWord64Dec wordValue)+            === stableHashBuilder (Builder.word64Dec wordValue),+      testCase "byte-string block reader preserves partial-state overlaps" $+        let sampleBytes byteLength =+              ByteString.pack (take byteLength (cycle [0 .. 251]))+            prefixes =+              fmap sampleBytes [0 .. 15]+            payloads =+              fmap sampleBytes [0 .. 40]+            assertOverlap prefix payload =+              sipHashFinalize+                ( sipHashUpdateByteString+                    (sipHashUpdateByteString (sipHashInit defaultStableHashKey) prefix)+                    payload+                )+                @?= sipHashDigest defaultStableHashKey (prefix <> payload)+         in traverse_ (\prefix -> traverse_ (assertOverlap prefix) payloads) prefixes,+      testCase "sipHash24 reacts to key changes" $+        assertBool+          "different keys should perturb the digest"+          (sipHash24 17 23 (BS8.pack "meridian") /= sipHash24 17 24 (BS8.pack "meridian")),+      testProperty "framed fold is byte-for-byte identical to materialized one-shot sipHash" $+        \chunkWordLists ->+          let chunks = map ByteString.pack (chunkWordLists :: [[Word8]])+           in unStableHashDigest (stableHashByteStrings chunks)+                === sipHashDigest defaultStableHashKey (referenceFramedBytes chunks),+      testProperty "encoding chunks preserve byte-string framing" $+        \chunkWordLists ->+          let chunks = map ByteString.pack (chunkWordLists :: [[Word8]])+           in stableHashEncodingChunks stableHashEncodingByteString chunks+                === stableHashByteStrings chunks+    ]++-- The exact byte preimage 'stableHashByteStrings' streams into SipHash: version+-- word, compact chunk count, then each compact length-prefixed chunk. Hashing+-- this in one shot with @memory@'s 'sipHashDigest' proves the streamed fold+-- matches the authoritative framed byte sequence for every corpus.+referenceFramedBytes :: [ByteString] -> ByteString+referenceFramedBytes chunks =+  LazyByteString.toStrict+    ( Builder.toLazyByteString+        ( Builder.word64LE stableHashEncodingVersion+            <> compactWord64Builder (fromIntegral (length chunks))+            <> foldMap encodeChunk chunks+        )+    )+  where+    encodeChunk chunk =+      compactWord64Builder (fromIntegral (ByteString.length chunk))+        <> Builder.byteString chunk++compactWord64Builder :: Word64 -> Builder.Builder+compactWord64Builder wordValue =+  let byteValue =+        fromIntegral (wordValue `rem` 128)+      remainingValue =+        wordValue `quot` 128+   in if remainingValue == 0+        then Builder.word8 byteValue+        else Builder.word8 (byteValue + 128) <> compactWord64Builder remainingValue
+ test/basis/TotalRegistrySpec.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeApplications #-}++module TotalRegistrySpec (tests) where++import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Moonlight.Core+  ( FiniteUniverse (..),+    boundedEnumUniverse,+    finiteUniverseList,+  )+import SourceShape (assertSourceShape)+import Moonlight.Core+  ( lookupTotal,+    mkTotalRegistry,+  )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++data RegistryKey+  = RegistryA+  | RegistryB+  | RegistryC+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance FiniteUniverse RegistryKey where+  finiteUniverse =+    boundedEnumUniverse++data OutsideUniverseKey+  = InsideUniverse+  | OutsideUniverse+  deriving stock (Eq, Ord, Show)++instance FiniteUniverse OutsideUniverseKey where+  finiteUniverse =+    InsideUniverse :| []++tests :: TestTree+tests =+  testGroup+    "TotalRegistry"+    [ testCase "full registry resolves every finite key in universe order" testFullRegistryResolvesUniverse,+      testCase "incomplete registry reports missing keys in finite-universe order" testMissingKeysReportedInUniverseOrder,+      testCase "lookupTotal can be used as a first-class resolver" testLookupTotalFirstClassResolver,+      testCase "lookupTotal falls back to the first finite-universe value outside the retained map" testLookupTotalOutsideUniverseFallback,+      testCase "TotalRegistry source stays checked and partial-free" testTotalRegistrySourceShape+    ]++testFullRegistryResolvesUniverse :: IO ()+testFullRegistryResolvesUniverse =+  case mkTotalRegistry fullRegistryEntries of+    Left missingKeys ->+      assertFailure ("expected full registry, missing keys: " <> show missingKeys)+    Right registry ->+      fmap (lookupTotal registry) (finiteUniverseList @RegistryKey) @?= [10, 20, 30]++testMissingKeysReportedInUniverseOrder :: IO ()+testMissingKeysReportedInUniverseOrder =+  case mkTotalRegistry missingRegistryEntries of+    Left missingKeys ->+      missingKeys @?= [RegistryB, RegistryC]+    Right _registry ->+      assertFailure "expected RegistryB and RegistryC to be reported missing"++testLookupTotalFirstClassResolver :: IO ()+testLookupTotalFirstClassResolver =+  case mkTotalRegistry fullRegistryEntries of+    Left missingKeys ->+      assertFailure ("expected full registry, missing keys: " <> show missingKeys)+    Right registry -> do+      let resolve = lookupTotal registry+      fmap resolve [RegistryC, RegistryA] @?= [30, 10]++testLookupTotalOutsideUniverseFallback :: IO ()+testLookupTotalOutsideUniverseFallback =+  case mkTotalRegistry (Map.singleton InsideUniverse 99) of+    Left missingKeys ->+      assertFailure ("expected registry with the declared finite universe, missing keys: " <> show missingKeys)+    Right registry ->+      lookupTotal registry OutsideUniverse @?= 99++testTotalRegistrySourceShape :: IO ()+testTotalRegistrySourceShape =+  assertSourceShape+    __FILE__+    "src-basis/Moonlight/Core/TotalRegistry.hs"+    [ "mkTotalRegistry",+      "lookupTotal"+    ]+    [ "Map.!",+      "fromJust",+      "error",+      "undefined"+    ]++fullRegistryEntries :: Map.Map RegistryKey Int+fullRegistryEntries =+  Map.fromList+    [ (RegistryA, 10),+      (RegistryB, 20),+      (RegistryC, 30)+    ]++missingRegistryEntries :: Map.Map RegistryKey Int+missingRegistryEntries =+  Map.singleton RegistryA 10
+ test/basis/TypeLevelSpec.hs view
@@ -0,0 +1,20 @@+module TypeLevelSpec (tests) where++import GHC.TypeNats (natVal)+import Numeric.Natural (Natural)+import Moonlight.Core (SNat(..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++snatToNatural :: SNat n -> Natural+snatToNatural s@SNat = natVal s++tests :: TestTree+tests = testGroup "TypeLevel"+  [ testCase "SNat @0 witnesses 0" $+      snatToNatural (SNat @0) @?= 0+  , testCase "SNat @42 witnesses 42" $+      snatToNatural (SNat @42) @?= 42+  , testCase "SNat @1000000 witnesses 1000000" $+      snatToNatural (SNat @1000000) @?= 1000000+  ]
+ test/basis/ValidationSpec.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE DerivingStrategies #-}++module ValidationSpec (tests) where++import Data.Set (Set)+import Data.Set qualified as Set+import Moonlight.Core (IsLawName (..), constructorLawName)+import LawProperty (lawProperty)+import Moonlight.Core+  ( Validation (..),+    collectEither,+    eitherToValidation,+    mapValidationError,+    validationToEither,+  )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck+  ( Arbitrary (..),+    Gen,+    Property,+    chooseInt,+    listOf,+    (===),+    (.&&.),+  )++newtype ErrorBag = ErrorBag (Set Int)+  deriving stock (Eq, Show)++instance Semigroup ErrorBag where+  ErrorBag left <> ErrorBag right =+    ErrorBag (Set.union left right)++instance Arbitrary ErrorBag where+  arbitrary =+    ErrorBag . Set.fromList <$> listOf validationErrorCode++data ValidationLaw+  = ValidationEitherRoundTrip+  | ValidationErrorAccumulationAssociative+  | ValidationErrorAccumulationCommutativeForCommutativeErrors+  | ValidationApplicativeNeverDropsErrors+  | ValidationCollectEitherNeverDropsErrors+  | ValidationMapErrorFunctor+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance IsLawName ValidationLaw where+  lawNameText =+    constructorLawName . show++tests :: TestTree+tests =+  testGroup+    "Validation"+    [ lawProperty ValidationEitherRoundTrip propEitherRoundTrip,+      lawProperty ValidationErrorAccumulationAssociative propErrorAccumulationAssociative,+      lawProperty ValidationErrorAccumulationCommutativeForCommutativeErrors propErrorAccumulationCommutative,+      lawProperty ValidationApplicativeNeverDropsErrors propApplicativeNeverDropsErrors,+      lawProperty ValidationCollectEitherNeverDropsErrors propCollectEitherNeverDropsErrors,+      lawProperty ValidationMapErrorFunctor propMapErrorFunctor+    ]++validationErrorCode :: Gen Int+validationErrorCode =+  chooseInt (-64, 64)++propEitherRoundTrip :: Either [Int] Int -> Property+propEitherRoundTrip eitherValue =+  validationToEither validationValue === eitherValue+    .&&. eitherToValidation (validationToEither validationValue) === validationValue+  where+    validationValue =+      eitherToValidation eitherValue++propErrorAccumulationAssociative :: Int -> Int -> Int -> Property+propErrorAccumulationAssociative left middle right =+  leftGrouped === (Invalid [left, middle, right] :: Validation [Int] ((Int, Int), Int))+    .&&. rightGrouped === (Invalid [left, middle, right] :: Validation [Int] (Int, (Int, Int)))+  where+    leftGrouped =+      liftA2+        (,)+        (liftA2 (,) (Invalid [left] :: Validation [Int] Int) (Invalid [middle] :: Validation [Int] Int))+        (Invalid [right] :: Validation [Int] Int)+    rightGrouped =+      liftA2+        (,)+        (Invalid [left] :: Validation [Int] Int)+        (liftA2 (,) (Invalid [middle] :: Validation [Int] Int) (Invalid [right] :: Validation [Int] Int))++propErrorAccumulationCommutative :: ErrorBag -> ErrorBag -> Property+propErrorAccumulationCommutative left right =+  leftFirst === rightFirst+  where+    leftFirst =+      (Invalid left :: Validation ErrorBag (Int -> Int))+        <*> (Invalid right :: Validation ErrorBag Int)+    rightFirst =+      (Invalid right :: Validation ErrorBag (Int -> Int))+        <*> (Invalid left :: Validation ErrorBag Int)++propApplicativeNeverDropsErrors :: Int -> Int -> Property+propApplicativeNeverDropsErrors left right =+  ((Invalid [left] :: Validation [Int] (Int -> Int)) <*> (Invalid [right] :: Validation [Int] Int))+    === (Invalid [left, right] :: Validation [Int] Int)++propCollectEitherNeverDropsErrors :: Int -> Int -> [Int] -> Property+propCollectEitherNeverDropsErrors left right validValues =+  collectEither eitherValues === Left [left, right]+  where+    eitherValues =+      Left [left] : (Right <$> validValues) <> [Left [right]]++propMapErrorFunctor :: Either Int String -> Property+propMapErrorFunctor eitherValue =+  mapValidationError id validationValue === validationValue+    .&&. mapValidationError ((+ 1) . (* 2)) validationValue+      === mapValidationError (+ 1) (mapValidationError (* 2) validationValue)+  where+    validationValue =+      eitherToValidation eitherValue
+ test/facade/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import qualified PublicSurfaceSpec+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain PublicSurfaceSpec.tests
+ test/facade/PublicSurfaceSpec.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE CPP #-}++module PublicSurfaceSpec (tests) where++import Control.Exception (SomeException, evaluate, try)+import Control.Monad (void)+import Data.Char (isSpace)+import Data.List (isPrefixOf)+import Data.Text (pack)+import SourceShape (assertTopLevelDeclarationExcludesToken)+import Moonlight.Core (Refined, isQualifiedModuleName, refinedValue, spectralGap, splitModuleName)+import Moonlight.Core.Unsound (TrustJustification, unsafelyTrustRefined)+import System.FilePath (takeDirectory, (</>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "PublicSurface"+    [ testCase "validated public tokens do not derive Read" testValidatedPublicTokensDoNotDeriveRead,+      testCase "module identifier splitting uses the Text segment owner" testModuleIdentifierTextSegments,+      testCase "spectralGap uses the two smallest sorted values" testSpectralGapUsesSortedValues,+      testCase "default public library exposes only Moonlight.Core" testDefaultPublicLibraryExposesOnlyCore,+      testCase "default public library reexports only Moonlight.Core.Unsound" testDefaultPublicLibraryReexportsOnlyUnsound,+      testCase "named public sublibraries expose the declared direct modules" testPublicNamedSublibrarySurface,+      testCase "egraph program sublibrary is public and canonically exposed" testEGraphProgramSublibrarySurface,+      testCase "unsafelyTrustRefined forces trust justification before minting Refined" testUnsafelyTrustRefinedForcesTrustJustification+    ]++data UnsafelyTrustRefinedProbe++testUnsafelyTrustRefinedForcesTrustJustification :: IO ()+testUnsafelyTrustRefinedForcesTrustJustification =+  assertIOFails $+    evaluate $+      refinedValue+        ( unsafelyTrustRefined+            (undefined :: TrustJustification)+            (42 :: Int) ::+            Refined UnsafelyTrustRefinedProbe Int+        )++testValidatedPublicTokensDoNotDeriveRead :: IO ()+testValidatedPublicTokensDoNotDeriveRead = do+  assertTopLevelDeclarationExcludesToken+    __FILE__+    "src-basis/Moonlight/Internal/Unsound.hs"+    "newtype Refined"+    "Read"+  assertTopLevelDeclarationExcludesToken+    __FILE__+    "src-basis/Moonlight/Internal/Unsound.hs"+    "newtype IdentifierToken"+    "Read"+  assertTopLevelDeclarationExcludesToken+    __FILE__+    "src-basis/Moonlight/Core/DomainId/Internal.hs"+    "newtype DomainId"+    "Read"++testModuleIdentifierTextSegments :: IO ()+testModuleIdentifierTextSegments = do+  splitModuleName (pack "Moonlight.Core.Test") @?= fmap pack ["Moonlight", "Core", "Test"]+  isQualifiedModuleName (pack "Moonlight.Core.Test") @?= True+  isQualifiedModuleName (pack "Moonlight..Core") @?= False++testSpectralGapUsesSortedValues :: IO ()+testSpectralGapUsesSortedValues =+  spectralGap [5 :: Int, 1, 3] @?= Just 2++testDefaultPublicLibraryExposesOnlyCore :: IO ()+testDefaultPublicLibraryExposesOnlyCore = do+  cabalText <- readFile (packageRootFromTestModule __FILE__ </> "moonlight-core.cabal")+  case defaultPublicLibraryExposedModules cabalText of+    Left parseFailure ->+      assertFailure parseFailure+    Right exposedModules ->+      exposedModules @?= ["Moonlight.Core"]++testDefaultPublicLibraryReexportsOnlyUnsound :: IO ()+testDefaultPublicLibraryReexportsOnlyUnsound = do+  cabalText <- readFile (packageRootFromTestModule __FILE__ </> "moonlight-core.cabal")+  case defaultPublicLibraryReexports cabalText of+    Left parseFailure ->+      assertFailure parseFailure+    Right reexports ->+      reexports @?= ["Moonlight.Core.Unsound"]++testPublicNamedSublibrarySurface :: IO ()+testPublicNamedSublibrarySurface = do+  cabalText <- readFile (packageRootFromTestModule __FILE__ </> "moonlight-core.cabal")+  publicNamedLibraryExposedModules cabalText+    @?= Right+      [ "Moonlight.Core.EGraph.Program",+        "Moonlight.Core.Guidance",+        "Moonlight.Core.Language",+        "Moonlight.Core.Pattern",+        "Moonlight.Core.Pattern.AntiUnify",+        "Moonlight.Core.Fix.Order",+        "Moonlight.Core.Site.Program",+        "Moonlight.Core.Substitution",+        "Moonlight.Core.Theory",+        "Moonlight.Automata.Pure.Algebra",+        "Moonlight.Automata.Pure.Coalgebra",+        "Moonlight.Automata.Pure.Core",+        "Moonlight.Automata.Pure.Transducer",+        "Moonlight.Core.Pattern.Automata",+        "Moonlight.Core.Pattern.Kernel"+      ]++testEGraphProgramSublibrarySurface :: IO ()+testEGraphProgramSublibrarySurface = do+  cabalText <- readFile (packageRootFromTestModule __FILE__ </> "moonlight-core.cabal")+  namedLibraryFieldValues "moonlight-core-egraph-program" "visibility" cabalText+    @?= Right ["public"]+  namedLibraryFieldValues "moonlight-core-egraph-program" "hs-source-dirs" cabalText+    @?= Right ["src-egraph-program"]+  namedLibraryFieldValues "moonlight-core-egraph-program" "exposed-modules" cabalText+    @?= Right ["Moonlight.Core.EGraph.Program"]++packageRootFromTestModule :: FilePath -> FilePath+packageRootFromTestModule testModulePath =+  takeDirectory $+    takeDirectory $+      takeDirectory $+        takeDirectory testModulePath++defaultPublicLibraryExposedModules :: String -> Either String [String]+defaultPublicLibraryExposedModules =+  defaultPublicLibraryFieldValues "exposed-modules"++defaultPublicLibraryReexports :: String -> Either String [String]+defaultPublicLibraryReexports =+  defaultPublicLibraryFieldValues "reexported-modules"++publicNamedLibraryExposedModules :: String -> Either String [String]+publicNamedLibraryExposedModules =+  fmap concat+    . traverse (fieldValues "exposed-modules")+    . filter isPublicNamedLibraryStanza+    . cabalStanzas+    . lines++isPublicNamedLibraryStanza :: [String] -> Bool+isPublicNamedLibraryStanza stanza =+  case stanza of+    stanzaHeader : _stanzaBody ->+      case words stanzaHeader of+        ["library", _libraryName] ->+          fieldValues "visibility" stanza == Right ["public"]+        _ -> False+    [] -> False++defaultPublicLibraryFieldValues :: String -> String -> Either String [String]+defaultPublicLibraryFieldValues fieldName cabalText =+  case filter isDefaultPublicLibraryStanza (cabalStanzas (lines cabalText)) of+    [] -> Left "expected to find the default library stanza with hs-source-dirs: src-public"+    [defaultLibraryStanza] -> fieldValues fieldName defaultLibraryStanza+    _multipleDefaultLibraries -> Left "expected exactly one default library stanza with hs-source-dirs: src-public"++cabalStanzas :: [String] -> [[String]]+cabalStanzas [] =+  []+cabalStanzas sourceLines =+  case dropWhile (not . isCabalStanzaHeader) sourceLines of+    [] -> []+    stanzaHeader : remainingLines ->+      let (stanzaBody, rest) = break isCabalStanzaHeader remainingLines+       in (stanzaHeader : stanzaBody) : cabalStanzas rest++isDefaultPublicLibraryStanza :: [String] -> Bool+isDefaultPublicLibraryStanza stanza =+  case stanza of+    stanzaHeader : stanzaBody ->+      trim stanzaHeader == "library" && any ((== "hs-source-dirs: src-public") . trim) stanzaBody+    [] -> False++namedLibraryFieldValues :: String -> String -> String -> Either String [String]+namedLibraryFieldValues libraryName fieldName cabalText =+  case filter (isNamedLibraryStanza libraryName) (cabalStanzas (lines cabalText)) of+    [] -> Left ("expected to find library stanza: " <> libraryName)+    [libraryStanza] -> fieldValues fieldName libraryStanza+    _multipleLibraries -> Left ("expected exactly one library stanza: " <> libraryName)++isNamedLibraryStanza :: String -> [String] -> Bool+isNamedLibraryStanza libraryName stanza =+  case stanza of+    stanzaHeader : _stanzaBody ->+      trim stanzaHeader == "library " <> libraryName+    [] -> False++fieldValues :: String -> [String] -> Either String [String]+fieldValues fieldName stanza =+  case dropWhile (not . isRequestedField) stanza of+    [] -> Left ("expected " <> fieldName <> " field in default library stanza")+    fieldLine : rest -> Right (fieldLineValues fieldLine <> continuationValues rest)+  where+    fieldPrefix = fieldName <> ":"+    isRequestedField line = fieldPrefix `isPrefixOf` trim line+    fieldLineValues line = fieldEntryValues (drop (length fieldPrefix) (trim line))+    continuationValues = fieldEntryValues . unlines . takeWhile (not . isCabalFieldStart)++fieldEntryValues :: String -> [String]+fieldEntryValues fieldText =+  filter (not . null) $+    fmap (trim . dropWhile (== ',') . trim) $+      lines fieldText++isCabalFieldStart :: String -> Bool+isCabalFieldStart sourceLine =+  case sourceLine of+    ' ' : ' ' : nextCharacter : _ -> nextCharacter /= ' ' && ':' `elem` sourceLine+    _ -> isCabalStanzaHeader sourceLine++isCabalStanzaHeader :: String -> Bool+isCabalStanzaHeader sourceLine =+  case words sourceLine of+    stanzaKind : _ | not (startsWithSpace sourceLine) -> stanzaKind `elem` cabalStanzaKinds+    _ -> False++cabalStanzaKinds :: [String]+cabalStanzaKinds =+  [ "benchmark",+    "common",+    "executable",+    "flag",+    "library",+    "test-suite"+  ]++startsWithSpace :: String -> Bool+startsWithSpace sourceLine =+  case sourceLine of+    leadingCharacter : _ -> isSpace leadingCharacter+    [] -> False++assertIOFails :: IO value -> IO ()+assertIOFails action = do+  result <- try (void action) :: IO (Either SomeException ())+  case result of+    Left _expectedFailure -> pure ()+    Right () -> assertFailure "expected IO action to fail"++trim :: String -> String+trim =+  trimRight . trimLeft++trimLeft :: String -> String+trimLeft =+  dropWhile isSpace++trimRight :: String -> String+trimRight =+  reverse . trimLeft . reverse
+ test/numeric/ApproxEqSpec.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE DerivingStrategies #-}++module ApproxEqSpec (tests) where++import Data.Word (Word32, Word64)+import GHC.Float (castDoubleToWord64, castFloatToWord32, castWord32ToFloat, castWord64ToDouble)+import Moonlight.Core+import Prelude+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))+import Test.Tasty.QuickCheck (Gen, NonNegative (..), Positive (..), Property, Testable, arbitrary, chooseBoundedIntegral, forAll, property, testProperty, (==>))++data ApproxEqLawName+  = ApproxEqAbsTolConstructorRejectsInvalid+  | ApproxEqAbsTolMonotonicity+  | ApproxEqAbsTolReflexivity+  | ApproxEqAbsTolSymmetry+  | ApproxEqFloatAbsTolReflexivity+  | ApproxEqFloatUlpTolMonotonicity+  | ApproxEqFloatUlpTolNativeAdjacentValues+  | ApproxEqFloatUlpTolReflexivity+  | ApproxEqFloatUlpTolRejectsNaNOperands+  | ApproxEqFloatUlpTolSymmetry+  | ApproxEqRelTolConstructorRejectsInvalid+  | ApproxEqRelTolMonotonicity+  | ApproxEqRelTolReflexivity+  | ApproxEqRelTolSymmetry+  | ApproxEqUlpTolMonotonicity+  | ApproxEqUlpTolNativeAdjacentValues+  | ApproxEqUlpTolReflexivity+  | ApproxEqUlpTolRejectsNaNOperands+  | ApproxEqUlpTolSymmetry+  | ApproxEqToleranceCompositeNormalForm+  | ApproxEqToleranceExactConjunctionBottom+  | ApproxEqToleranceExactDisjunctionIdentity+  | ApproxEqWithinTolAlias+  deriving stock (Eq, Ord, Show)++instance IsLawName ApproxEqLawName where+  lawNameText = constructorLawName . show+lawProperty :: Testable property => ApproxEqLawName -> property -> TestTree+lawProperty lawName =+  testProperty (lawNameText lawName)++lawCase :: ApproxEqLawName -> Assertion -> TestTree+lawCase lawName =+  testCase (lawNameText lawName)+withAbsTol :: Double -> (AbsTol -> Property) -> Property+withAbsTol rawTolerance prove =+  case absTol rawTolerance of+    Right tolerance ->+      prove tolerance+    Left _ ->+      property False++withRelTol :: Double -> (RelTol -> Property) -> Property+withRelTol rawTolerance prove =+  case relTol rawTolerance of+    Right tolerance ->+      prove tolerance+    Left _ ->+      property False++absTolMonotonic :: NonNegative Double -> NonNegative Double -> Double -> Double -> Property+absTolMonotonic (NonNegative narrowRaw) (NonNegative wideningRaw) x y =+  case (absTol narrowRaw, absTol (narrowRaw + wideningRaw)) of+    (Right narrowTolerance, Right wideTolerance) ->+      approxEq narrowTolerance x y ==> approxEq wideTolerance x y+    _ ->+      property True++relTolMonotonic :: NonNegative Double -> NonNegative Double -> Double -> Double -> Property+relTolMonotonic (NonNegative narrowRaw) (NonNegative wideningRaw) x y =+  case (relTol narrowRaw, relTol (narrowRaw + wideningRaw)) of+    (Right narrowTolerance, Right wideTolerance) ->+      approxEq narrowTolerance x y ==> approxEq wideTolerance x y+    _ ->+      property True++ulpTolMonotonic :: Property+ulpTolMonotonic =+  forAll ulpNeighborhood $ \(narrowTolerance, wideTolerance, x, y) ->+    approxEq (mkUlpTol narrowTolerance) x y ==> approxEq (mkUlpTol wideTolerance) x y++floatUlpTolMonotonic :: Property+floatUlpTolMonotonic =+  forAll floatUlpNeighborhood $ \(narrowTolerance, wideTolerance, x, y) ->+    approxEq (mkUlpTol narrowTolerance) x y ==> approxEq (mkUlpTol wideTolerance) x y++ulpNeighborhood :: Gen (Word64, Word64, Double, Double)+ulpNeighborhood = do+  x <- arbitrary+  offset <- chooseBoundedIntegral (0, 512)+  narrowTolerance <- chooseBoundedIntegral (0, 1024)+  wideMargin <- chooseBoundedIntegral (0, 1024)+  let y = castWord64ToDouble (castDoubleToWord64 x + offset)+  pure (narrowTolerance, narrowTolerance + wideMargin, x, y)++floatUlpNeighborhood :: Gen (Word64, Word64, Float, Float)+floatUlpNeighborhood = do+  x <- arbitrary+  offset <- chooseBoundedIntegral (0 :: Word32, 512)+  narrowTolerance <- chooseBoundedIntegral (0, 1024)+  wideMargin <- chooseBoundedIntegral (0, 1024)+  let y = castWord32ToFloat (castFloatToWord32 x + offset)+  pure (narrowTolerance, narrowTolerance + wideMargin, x, y)++assertUlpTolRejectsNaNOperands :: Assertion+assertUlpTolRejectsNaNOperands = do+  let tolerance = mkUlpTol maxBound+      nan = 0 / 0 :: Double+  assertBool "max ULP tolerance must reject a left NaN operand" (not (approxEq tolerance nan 0.0))+  assertBool "max ULP tolerance must reject a right NaN operand" (not (approxEq tolerance 0.0 nan))+  assertBool "max ULP tolerance must reject two NaN operands" (not (approxEq tolerance nan nan))++assertUlpTolNativeAdjacentValues :: Assertion+assertUlpTolNativeAdjacentValues = do+  let exactTolerance = mkUlpTol 0+      adjacentTolerance = mkUlpTol 1+      positiveZero = 0.0 :: Double+      negativeZero = -0.0 :: Double+      positiveMinSubnormal = castWord64ToDouble 0x0000000000000001+      negativeMinSubnormal = castWord64ToDouble 0x8000000000000001+  assertBool "Double ULP key must collapse IEEE zeros" (approxEq exactTolerance positiveZero negativeZero)+  assertBool "Double ULP key must accept adjacent positive subnormal" (approxEq adjacentTolerance positiveZero positiveMinSubnormal)+  assertBool "zero ULP tolerance must reject adjacent positive subnormal" (not (approxEq exactTolerance positiveZero positiveMinSubnormal))+  assertBool "Double ULP key must accept adjacent negative subnormal" (approxEq adjacentTolerance negativeZero negativeMinSubnormal)+  assertBool "zero ULP tolerance must reject adjacent negative subnormal" (not (approxEq exactTolerance negativeZero negativeMinSubnormal))++assertFloatUlpTolRejectsNaNOperands :: Assertion+assertFloatUlpTolRejectsNaNOperands = do+  let tolerance = mkUlpTol maxBound+      nan = 0 / 0 :: Float+  assertBool "max Float ULP tolerance must reject a left NaN operand" (not (approxEq tolerance nan 0.0))+  assertBool "max Float ULP tolerance must reject a right NaN operand" (not (approxEq tolerance 0.0 nan))+  assertBool "max Float ULP tolerance must reject two NaN operands" (not (approxEq tolerance nan nan))++assertFloatUlpTolNativeAdjacentValues :: Assertion+assertFloatUlpTolNativeAdjacentValues = do+  let exactTolerance = mkUlpTol 0+      adjacentTolerance = mkUlpTol 1+      positiveZero = 0.0 :: Float+      negativeZero = -0.0 :: Float+      positiveMinSubnormal = castWord32ToFloat 0x00000001+      negativeMinSubnormal = castWord32ToFloat 0x80000001+  assertBool "Float ULP key must collapse IEEE zeros" (approxEq exactTolerance positiveZero negativeZero)+  assertBool "Float ULP key must accept adjacent positive subnormal" (approxEq adjacentTolerance positiveZero positiveMinSubnormal)+  assertBool "zero ULP tolerance must reject adjacent positive subnormal" (not (approxEq exactTolerance positiveZero positiveMinSubnormal))+  assertBool "Float ULP key must accept adjacent negative subnormal" (approxEq adjacentTolerance negativeZero negativeMinSubnormal)+  assertBool "zero ULP tolerance must reject adjacent negative subnormal" (not (approxEq exactTolerance negativeZero negativeMinSubnormal))++assertToleranceCompositeNormalForm :: Assertion+assertToleranceCompositeNormalForm =+  expectRight (mkAbsTol 0.25) $ \absoluteTolerance ->+    expectRight (mkRelTol 0.5) $ \relativeTolerance -> do+      let absoluteBranch = AbsTolBound absoluteTolerance+          relativeBranch = RelTolBound relativeTolerance+          ulpBranch = UlpTolBound (mkUlpTol 4)+      normalizeTolerance+        ( CompositeTol+            (CompositeTol relativeBranch absoluteBranch)+            (CompositeTol relativeBranch ulpBranch)+        )+        @?= CompositeTol (CompositeTol absoluteBranch relativeBranch) ulpBranch++assertToleranceExactConjunctionBottom :: Assertion+assertToleranceExactConjunctionBottom =+  expectRight (mkAbsTol 0.25) $ \absoluteTolerance ->+    normalizeTolerance (CompositeTol (AbsTolBound absoluteTolerance) Exact) @?= Exact++assertToleranceExactDisjunctionIdentity :: Assertion+assertToleranceExactDisjunctionIdentity =+  expectRight (mkRelTol 0.5) $ \relativeTolerance -> do+    let relativeBranch = RelTolBound relativeTolerance+    normalizeTolerance (DisjunctiveTol Exact (DisjunctiveTol relativeBranch relativeBranch)) @?= relativeBranch++expectRight :: Show err => Either err value -> (value -> Assertion) -> Assertion+expectRight result prove =+  case result of+    Left err ->+      assertFailure ("expected Right, received Left: " <> show err)+    Right value ->+      prove value++tests :: TestTree+tests =+  testGroup+    "ApproxEq"+    [ testGroup+        "AbsTol Double"+        [ lawProperty ApproxEqAbsTolReflexivity $ \(x :: Double) ->+            fieldValueValid x ==> withAbsTol 1e-15 (\tolerance -> property (approxEq tolerance x x)),+          lawProperty ApproxEqAbsTolSymmetry $ \(x :: Double) (y :: Double) ->+            withAbsTol 0.1 (\tolerance -> property (approxEq tolerance x y == approxEq tolerance y x)),+          lawProperty ApproxEqAbsTolMonotonicity absTolMonotonic+        ],+      testGroup+        "RelTol Double"+        [ lawProperty ApproxEqRelTolReflexivity $ \(x :: Double) ->+            fieldValueValid x ==> withRelTol 1e-15 (\tolerance -> property (approxEq tolerance x x)),+          lawProperty ApproxEqRelTolSymmetry $ \(x :: Double) (y :: Double) ->+            withRelTol 0.01 (\tolerance -> property (approxEq tolerance x y == approxEq tolerance y x)),+          lawProperty ApproxEqRelTolMonotonicity relTolMonotonic+        ],+      testGroup+        "UlpTol Double"+        [ lawProperty ApproxEqUlpTolReflexivity $ \(x :: Double) ->+            fieldValueValid x ==> approxEq (mkUlpTol 0) x x,+          lawCase ApproxEqUlpTolRejectsNaNOperands assertUlpTolRejectsNaNOperands,+          lawProperty ApproxEqUlpTolSymmetry $ \(tolerance :: Word64) (x :: Double) (y :: Double) ->+            approxEq (mkUlpTol tolerance) x y == approxEq (mkUlpTol tolerance) y x,+          lawProperty ApproxEqUlpTolMonotonicity ulpTolMonotonic,+          lawCase ApproxEqUlpTolNativeAdjacentValues assertUlpTolNativeAdjacentValues+        ],+      testGroup+        "AbsTol Float"+        [ lawProperty ApproxEqFloatAbsTolReflexivity $ \(x :: Float) ->+            fieldValueValid x ==> withAbsTol 1e-6 (\tolerance -> property (approxEq tolerance x x))+        ],+      testGroup+        "UlpTol Float"+        [ lawProperty ApproxEqFloatUlpTolReflexivity $ \(x :: Float) ->+            fieldValueValid x ==> approxEq (mkUlpTol 0) x x,+          lawCase ApproxEqFloatUlpTolRejectsNaNOperands assertFloatUlpTolRejectsNaNOperands,+          lawProperty ApproxEqFloatUlpTolSymmetry $ \(tolerance :: Word64) (x :: Float) (y :: Float) ->+            approxEq (mkUlpTol tolerance) x y == approxEq (mkUlpTol tolerance) y x,+          lawProperty ApproxEqFloatUlpTolMonotonicity floatUlpTolMonotonic,+          lawCase ApproxEqFloatUlpTolNativeAdjacentValues assertFloatUlpTolNativeAdjacentValues+        ],+      testGroup+        "withinTol"+        [ lawProperty ApproxEqWithinTolAlias $ \(x :: Double) (y :: Double) ->+            withAbsTol 0.01 (\tolerance -> property (withinTol tolerance x y == approxEq tolerance x y))+        ],+      testGroup+        "Tolerance constructors"+        [ lawProperty ApproxEqAbsTolConstructorRejectsInvalid $ \(Positive invalidMagnitude :: Positive Double) ->+            case (mkAbsTol (negate invalidMagnitude), absTol (negate invalidMagnitude)) of+              (Left _, Left _) -> True+              _ -> False,+          lawCase ApproxEqRelTolConstructorRejectsInvalid $ do+            case mkRelTol (0 / 0) of+              Left _ -> pure ()+              Right _ -> assertFailure "relative tolerance accepted NaN"+            case relTol (1 / 0) of+              Left _ -> pure ()+              Right _ -> assertFailure "relative tolerance accepted infinity"+        ],+      testGroup+        "Tolerance normal form"+        [ lawCase ApproxEqToleranceCompositeNormalForm assertToleranceCompositeNormalForm,+          lawCase ApproxEqToleranceExactConjunctionBottom assertToleranceExactConjunctionBottom,+          lawCase ApproxEqToleranceExactDisjunctionIdentity assertToleranceExactDisjunctionIdentity+        ]+    ]
+ test/numeric/CanonSpec.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE DerivingStrategies #-}++module CanonSpec (tests) where++import Data.Int (Int64)+import Data.Word (Word32)+import Moonlight.Core+import Prelude+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase, (@?=))+import Test.Tasty.QuickCheck (NonNegative (..), Property, Testable, testProperty, (==>))++data CanonLawName+  = CanonCanonicalizeIdempotent+  | CanonCanonicalizeNormalizesNegativeZero+  | CanonCanonicalizeRejectsInfinite+  | CanonCanonicalizeRejectsNaN+  | CanonCanonicalizeReturnsCanonical+  | CanonIsCanonicalIdentity+  | CanonMkFiniteDoubleAgreesWithCanonicalize+  | CanonMkNonNegativeFiniteCanonicalizes+  | CanonMkPositiveFiniteRejectsNonPositive+  | CanonQuantizeFinitePrecisionTotal+  | CanonQuantizeRejectsInvalidPrecision+  | CanonQuantizeRejectsNonFinite+  | CanonQuantizeSaturatesMaximum+  | CanonQuantizeSaturatesMinimum+  deriving stock (Eq, Ord, Show)++instance IsLawName CanonLawName where+  lawNameText = constructorLawName . show+lawProperty :: Testable property => CanonLawName -> property -> TestTree+lawProperty lawName =+  testProperty (lawNameText lawName)++lawCase :: CanonLawName -> Assertion -> TestTree+lawCase lawName =+  testCase (lawNameText lawName)+finiteDouble :: Double -> Bool+finiteDouble value =+  not (isNaN value) && not (isInfinite value)++validHashPrecision :: Word32 -> Word32+validHashPrecision precision =+  precision `mod` 10++canonicalizeReturnsCanonical :: Double -> Bool+canonicalizeReturnsCanonical value =+  case canonicalize value of+    Right canonicalValue ->+      isCanonical canonicalValue+    Left _ ->+      True++mkFiniteDoubleAgreesWithCanonicalize :: Double -> Bool+mkFiniteDoubleAgreesWithCanonicalize value =+  case (mkFiniteDouble "test" value, canonicalize value) of+    (Right finiteValue, Right canonicalValue) ->+      finiteValue == canonicalValue+    (Left _, Left _) ->+      True+    _ ->+      False++quantizeFinitePrecisionTotal :: Word32 -> Double -> Property+quantizeFinitePrecisionTotal precision value =+  finiteDouble value ==>+    case quantizeForHash (validHashPrecision precision) value of+      Right _ -> True+      Left _ -> False++tests :: TestTree+tests =+  testGroup+    "Canon"+    [ testGroup+        "canonicalize"+        [ lawCase CanonCanonicalizeRejectsNaN $+            canonicalize (0 / 0) @?= Left (NonFiniteValue CanonicalizeContext NaNInput),+          lawCase CanonCanonicalizeRejectsInfinite $ do+            canonicalize (1 / 0) @?= Left (NonFiniteValue CanonicalizeContext InfiniteInput)+            canonicalize ((-1) / 0) @?= Left (NonFiniteValue CanonicalizeContext InfiniteInput),+          lawCase CanonCanonicalizeNormalizesNegativeZero $+            canonicalize (-0.0) @?= Right 0.0,+          lawProperty CanonCanonicalizeIdempotent $ \(x :: Double) ->+            case canonicalize x of+              Right y -> canonicalize y == Right y+              Left _ -> True,+          lawProperty CanonCanonicalizeReturnsCanonical canonicalizeReturnsCanonical+        ],+      testGroup+        "isCanonical"+        [ lawProperty CanonIsCanonicalIdentity $ \(x :: Double) ->+            isCanonical x ==> canonicalize x == Right x+        ],+      testGroup+        "finite constructors"+        [ lawProperty CanonMkFiniteDoubleAgreesWithCanonicalize mkFiniteDoubleAgreesWithCanonicalize,+          lawProperty CanonMkNonNegativeFiniteCanonicalizes $ \(NonNegative x :: NonNegative Double) ->+            finiteDouble x ==>+              case mkNonNegativeFiniteDouble "test" x of+                Right y -> isCanonical y && y >= 0.0+                Left _ -> False,+          lawProperty CanonMkPositiveFiniteRejectsNonPositive $ \(NonNegative x :: NonNegative Double) ->+            finiteDouble x ==>+              case mkPositiveFiniteDouble "test" (negate x) of+                Left _ -> True+                Right _ -> False+        ],+      testGroup+        "quantizeForHash"+        [ lawProperty CanonQuantizeFinitePrecisionTotal quantizeFinitePrecisionTotal,+          lawProperty CanonQuantizeRejectsInvalidPrecision $ \(precision :: Word32) (x :: Double) ->+            precision > 9 ==> case quantizeForHash precision x of+              Left _ -> True+              Right _ -> False,+          testCase "quantize rejects invalid precision with typed error" $+            quantizeForHash 10 1.0 @?= Left (QuantizePrecisionTooLarge 10),+          lawCase CanonQuantizeRejectsNonFinite $ do+            quantizeForHash 0 (0 / 0) @?= Left (NonFiniteValue QuantizeContext NaNInput)+            quantizeForHash 0 (1 / 0) @?= Left (NonFiniteValue QuantizeContext InfiniteInput),+          lawCase CanonQuantizeSaturatesMaximum $+            quantizeForHash 0 (fromIntegral (maxBound :: Int64) * 2.0) @?= Right maxBound,+          lawCase CanonQuantizeSaturatesMinimum $+            quantizeForHash 0 (fromIntegral (minBound :: Int64) * 2.0) @?= Right minBound+        ]+    ]
+ test/numeric/CanonicalNumberSpec.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}++module CanonicalNumberSpec (tests) where++import Moonlight.Core+import Moonlight.Core.Unsound (unsafeCanonicalFiniteAssumeCanonical, unsafeCanonicalFiniteLiteral)+import SourceShape (assertSourceShape)+import Prelude+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))+import Test.Tasty.QuickCheck (Property, Testable, testProperty, (==>))++data CanonicalNumberLawName+  = CanonicalFiniteConstructorRejectsNonFinite+  | CanonicalFiniteConstructorReturnsCanonical+  | CanonicalFiniteConstructorRoundTrip+  | CanonicalFiniteUnsafeAssumptionNormalizesNegativeZero+  | CanonicalFiniteUnsafeLiteralNormalizesNegativeZero+  | CanonicalNumberFiniteFromDoubleAgreesWithConstructor+  | CanonicalNumberFiniteMaybeRoundTrip+  | CanonicalNumberNonFiniteClassification+  | CanonicalNumberReadBoundaryExcludesHiddenConstructors+  deriving stock (Eq, Ord, Show)++instance IsLawName CanonicalNumberLawName where+  lawNameText = constructorLawName . show+lawProperty :: Testable property => CanonicalNumberLawName -> property -> TestTree+lawProperty lawName =+  testProperty (lawNameText lawName)++lawCase :: CanonicalNumberLawName -> Assertion -> TestTree+lawCase lawName =+  testCase (lawNameText lawName)++assertCanonicalNumberReadBoundaryShape :: Assertion+assertCanonicalNumberReadBoundaryShape =+  assertSourceShape+    __FILE__+    "src-numeric/Moonlight/Core/CanonicalNumber/Internal.hs"+    [ "newtype CanonicalFiniteValue = CanonicalFiniteValue",+      "data CanonicalNumber"+    ]+    [ "Read"+    ]+++finiteDouble :: Double -> Bool+finiteDouble value =+  not (isNaN value) && not (isInfinite value)++canonicalFiniteConstructorRoundTrip :: Double -> Property+canonicalFiniteConstructorRoundTrip value =+  finiteDouble value ==>+    case (canonicalize value, mkCanonicalFiniteValue value) of+      (Right canonicalValue, Right finiteValue) ->+        canonicalFiniteValue finiteValue == canonicalValue+      _ ->+        False++canonicalNumberFiniteRoundTrip :: Double -> Property+canonicalNumberFiniteRoundTrip value =+  finiteDouble value ==>+    case (canonicalize value, mkCanonicalFiniteNumber value) of+      (Right canonicalValue, Right finiteNumber) ->+        canonicalNumberToMaybeDouble finiteNumber == Just canonicalValue+      _ ->+        False++tests :: TestTree+tests =+  testGroup+    "CanonicalNumber"+    [ lawCase CanonicalNumberReadBoundaryExcludesHiddenConstructors assertCanonicalNumberReadBoundaryShape,+      testGroup+        "CanonicalFiniteValue"+        [ lawCase CanonicalFiniteConstructorRejectsNonFinite $ do+            mkCanonicalFiniteValue (0 / 0) @?= Left (NonFiniteValue CanonicalizeContext NaNInput)+            case mkCanonicalFiniteValue (1 / 0) of+              Left _ -> pure ()+              Right _ -> assertFailure "canonical finite constructor accepted infinity",+          lawProperty CanonicalFiniteConstructorReturnsCanonical $ \(x :: Double) ->+            case mkCanonicalFiniteValue x of+              Right finiteValue -> isCanonical (canonicalFiniteValue finiteValue)+              Left _ -> True,+          lawProperty CanonicalFiniteConstructorRoundTrip canonicalFiniteConstructorRoundTrip,+          lawCase CanonicalFiniteUnsafeLiteralNormalizesNegativeZero $+            canonicalFiniteValue (unsafeCanonicalFiniteLiteral (-0.0)) @?= 0.0,+          lawCase CanonicalFiniteUnsafeAssumptionNormalizesNegativeZero $+            canonicalFiniteValue (unsafeCanonicalFiniteAssumeCanonical (-0.0)) @?= 0.0+        ],+      testGroup+        "CanonicalNumber"+        [ lawProperty CanonicalNumberFiniteFromDoubleAgreesWithConstructor $ \(x :: Double) ->+            finiteDouble x ==> canonicalNumberFromDouble x == either (const NaN) id (mkCanonicalFiniteNumber x),+          lawProperty CanonicalNumberFiniteMaybeRoundTrip canonicalNumberFiniteRoundTrip,+          lawCase CanonicalNumberNonFiniteClassification $ do+            canonicalNumberFromDouble (1 / 0) @?= PosInf+            canonicalNumberFromDouble ((-1) / 0) @?= NegInf+            assertBool "NaN classifies as NaN" (canonicalNumberFromDouble (0 / 0) == NaN)+        ]+    ]
+ test/numeric/ExactTokenSpec.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}++module ExactTokenSpec (tests) where++import Data.ByteString.Builder qualified as Builder+import Data.ByteString.Lazy qualified as LazyByteString+import Data.ByteString.Short qualified as ShortByteString+import Data.Int (Int64)+import Data.Kind (Type)+import Data.Word (Word8)+import Moonlight.Core+  ( ExactEncoding,+    ExactEncodingAtom (..),+    ExactToken,+    exactAtomEncoding,+    exactEncodingLength,+    exactSequenceEncoding,+    exactTokenBytes,+    exactTokenFromEncoding,+    exactTokenLength,+  )+import Moonlight.Core (IsLawName (..), constructorLawName)+import SourceShape (assertSourceShape)+import Prelude+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, testCase)+import Test.Tasty.QuickCheck (Arbitrary (arbitrary), Gen, Testable, frequency, listOf, resize, sized, testProperty)++data ExactTokenLawName+  = ExactTokenAtomSubtypeSeparation+  | ExactTokenEncodingDeterminism+  | ExactTokenReferenceEncodingAgreement+  | ExactTokenSequenceLengthLaw+  | ExactTokenEmptySequenceSeparation+  | ExactTokenSingletonSequenceSeparation+  | ExactTokenChildBoundarySeparation+  | ExactTokenNestingSeparation+  deriving stock (Eq, Ord, Show)++instance IsLawName ExactTokenLawName where+  lawNameText = constructorLawName . show++lawProperty :: Testable property => ExactTokenLawName -> property -> TestTree+lawProperty lawName =+  testProperty (lawNameText lawName)++lawCase :: ExactTokenLawName -> Assertion -> TestTree+lawCase lawName =+  testCase (lawNameText lawName)++assertExactTokenEncodingBoundaryShape :: IO ()+assertExactTokenEncodingBoundaryShape =+  assertSourceShape+    __FILE__+    "src-numeric/Moonlight/Core/ExactToken.hs"+    [ "exactTokenFromEncoding :: ExactEncoding -> ExactToken",+      "exactTokenBytes :: ExactToken -> Either ExactEncodingError ShortByteString",+      "exactSequenceMapEncoding :: Foldable values => (value -> ExactEncoding) -> values value -> ExactEncoding",+      "type ExactEncodingWriter =",+      "newByteArray#",+      "writeWord8Array#"+    ]+    [ "instance Semigroup ExactEncoding",+      "instance Monoid ExactEncoding",+      "exactConcatEncoding",+      "exactCountedEncoding",+      "Data.ByteString.Builder",+      "Builder.toLazyByteString",+      "LazyByteString.toStrict"+    ]++type SampleEncodingSeed :: Type+data SampleEncodingSeed+  = SampleAtom ExactEncodingAtom+  | SampleSequence [SampleEncodingSeed]+  deriving stock (Eq, Show)++sampleEncoding :: SampleEncodingSeed -> ExactEncoding+sampleEncoding seed =+  case seed of+    SampleAtom atom ->+      exactAtomEncoding atom+    SampleSequence children ->+      exactSequenceEncoding (fmap sampleEncoding children)++sampleExactToken :: SampleEncodingSeed -> ExactToken+sampleExactToken =+  exactTokenFromEncoding . sampleEncoding++sampleEncodingAtomGen :: Gen SampleEncodingSeed+sampleEncodingAtomGen =+  frequency+    [ (1, SampleAtom . ExactWord8 <$> arbitrary),+      (1, SampleAtom . ExactInt <$> arbitrary)+    ]++sampleEncodingGenSized :: Int -> Gen SampleEncodingSeed+sampleEncodingGenSized size =+  case size of+    0 ->+      sampleEncodingAtomGen+    _ ->+      frequency+        [ (2, sampleEncodingAtomGen),+          (1, SampleSequence <$> childSeedListGen)+        ]+  where+    childSeedSize = size `div` 2+    childSeedListGen =+      resize childSeedSize (listOf (sampleEncodingGenSized childSeedSize))++instance Arbitrary SampleEncodingSeed where+  arbitrary =+    sized sampleEncodingGenSized++sequenceLengthLaw :: [SampleEncodingSeed] -> Bool+sequenceLengthLaw children =+  exactEncodingLength (exactSequenceEncoding (fmap sampleEncoding children))+    == fmap (2 +) (sum <$> traverse (exactEncodingLength . sampleEncoding) children)++referenceEncoding :: SampleEncodingSeed -> Builder.Builder+referenceEncoding seed =+  case seed of+    SampleAtom (ExactWord8 byteValue) ->+      Builder.word8 0x01 <> Builder.word8 byteValue+    SampleAtom (ExactInt intValue) ->+      Builder.word8 0x02 <> Builder.int64BE (fromIntegral intValue :: Int64)+    SampleSequence children ->+      Builder.word8 0x03+        <> foldMap referenceEncoding children+        <> Builder.word8 0x04++productionBytes :: SampleEncodingSeed -> Either String LazyByteString.ByteString+productionBytes seed =+  case exactTokenBytes (exactTokenFromEncoding (sampleEncoding seed)) of+    Left encodingError -> Left (show encodingError)+    Right tokenBytes ->+      Right+        ( LazyByteString.fromStrict+            (ShortByteString.fromShort tokenBytes)+        )++referenceEncodingAgreement :: SampleEncodingSeed -> Bool+referenceEncodingAgreement seed =+  productionBytes seed == Right (Builder.toLazyByteString (referenceEncoding seed))++atomA :: SampleEncodingSeed+atomA = SampleAtom (ExactWord8 11)++atomB :: SampleEncodingSeed+atomB = SampleAtom (ExactInt 22)++atomC :: SampleEncodingSeed+atomC = SampleAtom (ExactWord8 33)++tests :: TestTree+tests =+  testGroup+    "exact-token"+    [ testCase "exact token boundary is one structural sequence algebra" assertExactTokenEncodingBoundaryShape,+      lawProperty ExactTokenEncodingDeterminism $+        \seed -> sampleExactToken seed == sampleExactToken seed,+      lawProperty ExactTokenReferenceEncodingAgreement referenceEncodingAgreement,+      lawProperty ExactTokenAtomSubtypeSeparation $+        \(byteValue :: Word8) ->+          sampleExactToken (SampleAtom (ExactWord8 byteValue))+            /= sampleExactToken (SampleAtom (ExactInt (fromIntegral byteValue))),+      lawProperty ExactTokenSingletonSequenceSeparation $+        \child -> sampleExactToken (SampleSequence [child]) /= sampleExactToken child,+      lawCase ExactTokenEmptySequenceSeparation $+        assertBool+          "an empty sequence must differ from a singleton empty sequence"+          ( sampleExactToken (SampleSequence [])+              /= sampleExactToken (SampleSequence [SampleSequence []])+          ),+      lawCase ExactTokenChildBoundarySeparation $+        assertBool+          "child boundaries must survive sequence encoding"+          ( sampleExactToken (SampleSequence [SampleSequence [atomA, atomB], atomC])+              /= sampleExactToken (SampleSequence [atomA, SampleSequence [atomB, atomC]])+          ),+      lawCase ExactTokenNestingSeparation $+        assertBool+          "left and right nesting must remain distinct"+          ( sampleExactToken (SampleSequence [SampleSequence [SampleSequence [atomA], atomB], atomC])+              /= sampleExactToken (SampleSequence [atomA, SampleSequence [atomB, SampleSequence [atomC]]])+          ),+      lawProperty ExactTokenSequenceLengthLaw sequenceLengthLaw,+      testProperty "sealed token length agrees with checked encoding length" $+        \seed ->+          exactTokenLength (exactTokenFromEncoding (sampleEncoding seed))+            == exactEncodingLength (sampleEncoding seed)+    ]
+ test/numeric/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import qualified NumericTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain NumericTests.tests
+ test/numeric/NicheSpec.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE DerivingStrategies #-}++module NicheSpec (tests) where++import Data.Bifunctor (first)+import Data.Text (Text, pack)+import Numeric.Natural (Natural)+import Prelude (Double, Either (..), Eq, Int, Maybe (..), Ord, Show, String, fromIntegral, map, maxBound, show, traverse, uncurry, (/), (+), (.))+import Moonlight.Core (IsLawName (..), constructorLawName)+import Moonlight.Core+  ( ActiveStressor,+    MoonlightError (NonFiniteValue),+    MoonlightErrorContext (CanonicalizeContext),+    NicheValidationError (..),+    NonFiniteInput (NaNInput),+    activeStressorId,+    activeStressorIntensity,+    activeStressorSetEntries,+    activeStressorSetFromList,+    activeStressorSetTopEntries,+    contextSignatureBins,+    mkActiveStressor,+    mkContextSignature,+    mkStressorId,+    mkTopoSample,+    renderStressorId,+  )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, (@?=), assertFailure, testCase)++data NicheLawName+  = NicheActiveStressorSetCanonicalOrder+  | NicheActiveStressorSetDeduplicatesByMaximumIntensity+  | NicheActiveStressorTopEntriesPrefix+  | NicheActiveStressorTopEntriesSaturatesHugeLimit+  | NicheContextSignaturePreservesBins+  | NicheStressorIdRejectsEmpty+  | NicheTopoSampleRejectsNegativeSlope+  | NicheTopoSampleRejectsNonFiniteCanonicalScalar+  deriving stock (Eq, Ord, Show)++instance IsLawName NicheLawName where+  lawNameText = constructorLawName . show++lawCase :: NicheLawName -> Assertion -> TestTree+lawCase lawName =+  testCase (lawNameText lawName)++tests :: TestTree+tests =+  testGroup+    "Niche"+    [ lawCase NicheStressorIdRejectsEmpty testInvalidStressorId,+      lawCase NicheTopoSampleRejectsNegativeSlope testInvalidTopoSample,+      lawCase NicheTopoSampleRejectsNonFiniteCanonicalScalar testInvalidTopoSampleCanonicalScalar,+      lawCase NicheActiveStressorSetDeduplicatesByMaximumIntensity testActiveStressorSetCanonical,+      lawCase NicheActiveStressorSetCanonicalOrder testActiveStressorSetCanonical,+      lawCase NicheActiveStressorTopEntriesPrefix testActiveStressorTopEntries,+      lawCase NicheActiveStressorTopEntriesSaturatesHugeLimit testActiveStressorTopEntriesHugeLimit,+      lawCase NicheContextSignaturePreservesBins testContextSignature+    ]++testInvalidStressorId :: Assertion+testInvalidStressorId =+  mkStressorId (pack "") @?= Nothing++testInvalidTopoSample :: Assertion+testInvalidTopoSample =+  mkTopoSample (-1.0) 0.0 0.0 @?= Left (NegativeTopoSlope (-1.0))++testInvalidTopoSampleCanonicalScalar :: Assertion+testInvalidTopoSampleCanonicalScalar =+  mkTopoSample (0 / 0) 0.0 0.0 @?= Left (NicheCanonicalScalarRejected (NonFiniteValue CanonicalizeContext NaNInput))++testActiveStressorSetCanonical :: Assertion+testActiveStressorSetCanonical =+  case buildStressors of+    Left err -> assertFailure err+    Right stressors ->+      map describeStressor (activeStressorSetEntries (activeStressorSetFromList stressors))+        @?= [(pack "ash", 0.9), (pack "bog", 0.8), (pack "cinder", 0.8)]++testActiveStressorTopEntries :: Assertion+testActiveStressorTopEntries =+  case buildStressors of+    Left err -> assertFailure err+    Right stressors ->+      map describeStressor (activeStressorSetTopEntries 2 (activeStressorSetFromList stressors))+        @?= [(pack "ash", 0.9), (pack "bog", 0.8)]++testActiveStressorTopEntriesHugeLimit :: Assertion+testActiveStressorTopEntriesHugeLimit =+  case buildStressors of+    Left err -> assertFailure err+    Right stressors ->+      map describeStressor (activeStressorSetTopEntries justPastIntLimit (activeStressorSetFromList stressors))+        @?= [(pack "ash", 0.9), (pack "bog", 0.8), (pack "cinder", 0.8)]++justPastIntLimit :: Natural+justPastIntLimit =+  fromIntegral (maxBound :: Int) + 1+++testContextSignature :: Assertion+testContextSignature =+  contextSignatureBins (mkContextSignature [3, 1, 4, 1]) @?= [3, 1, 4, 1]++buildStressors :: Either String [ActiveStressor]+buildStressors =+  case traverse mkStressorId stressorNames of+    Nothing -> Left "expected valid stressor ids"+    Just [bogId, ashId, cinderId] ->+      first show+        ( traverse+            (uncurry mkActiveStressor)+            [ (bogId, 0.2),+              (ashId, 0.9),+              (bogId, 0.8),+              (cinderId, 0.8)+            ]+        )+    Just _ -> Left "unexpected stressor id cardinality"+  where+    stressorNames = map pack ["bog", "ash", "cinder"]++describeStressor :: ActiveStressor -> (Text, Double)+describeStressor stressor =+  (renderStressorId (activeStressorId stressor), activeStressorIntensity stressor)
+ test/numeric/NumericTests.hs view
@@ -0,0 +1,24 @@+module NumericTests+  ( tests,+  )+where++import qualified ApproxEqSpec as ApproxEqSpec+import qualified CanonSpec as CanonSpec+import qualified CanonicalNumberSpec as CanonicalNumberSpec+import qualified ExactTokenSpec as ExactTokenSpec+import qualified NicheSpec as NicheSpec+import qualified ScalarLawsSpec as ScalarLawsSpec+import Test.Tasty (TestTree, testGroup)++tests :: TestTree+tests =+  testGroup+    "moonlight-core-numeric"+    [ ApproxEqSpec.tests,+      CanonSpec.tests,+      CanonicalNumberSpec.tests,+      ExactTokenSpec.tests,+      NicheSpec.tests,+      ScalarLawsSpec.tests+    ]
+ test/numeric/ScalarLawsSpec.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE DerivingStrategies #-}++module ScalarLawsSpec (tests) where++import Data.Maybe (isJust)+import Moonlight.Core+import Prelude+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase, (@?=))+import Test.Tasty.QuickCheck (Property, Testable, property, testProperty, (==>))++data ScalarLawName+  = ScalarAdditiveAssociativity+  | ScalarAdditiveCommutativity+  | ScalarAdditiveLeftIdentity+  | ScalarAdditiveLeftInverse+  | ScalarAdditiveNegationInvolution+  | ScalarAdditiveRightIdentity+  | ScalarAdditiveRightInverse+  | ScalarFieldCanInvertAgreement+  | ScalarFieldDivisionDefinition+  | ScalarFieldDivisionByOne+  | ScalarFieldDivisionByZero+  | ScalarFieldInverseMultiplicativeIdentity+  | ScalarFieldInverseResultFinite+  | ScalarFieldRejectsInverseOutOfRange+  | ScalarFieldRequireInvertibleAgreement+  | ScalarFieldZeroNotInvertible+  | ScalarLeftDistributivity+  | ScalarMetricNegationInvariant+  | ScalarMetricNonNegative+  | ScalarMetricZeroMagnitude+  | ScalarMultiplicativeAssociativity+  | ScalarMultiplicativeCommutativity+  | ScalarMultiplicativeLeftIdentity+  | ScalarMultiplicativeRightIdentity+  | ScalarRightDistributivity+  | ScalarSubtractionDefinition+  deriving stock (Eq, Ord, Show)++instance IsLawName ScalarLawName where+  lawNameText = constructorLawName . show+lawProperty :: Testable property => ScalarLawName -> property -> TestTree+lawProperty lawName =+  testProperty (lawNameText lawName)++lawCase :: ScalarLawName -> Assertion -> TestTree+lawCase lawName =+  testCase (lawNameText lawName)+tests :: TestTree+tests =+  testGroup+    "Scalar Laws"+    [ testGroup+        "AdditiveGroup Int"+        [ lawProperty ScalarAdditiveLeftIdentity $ \(x :: Int) ->+            add zero x == x,+          lawProperty ScalarAdditiveRightIdentity $ \(x :: Int) ->+            add x zero == x,+          lawProperty ScalarAdditiveLeftInverse $ \(x :: Int) ->+            add (neg x) x == zero,+          lawProperty ScalarAdditiveRightInverse $ \(x :: Int) ->+            add x (neg x) == zero,+          lawProperty ScalarAdditiveAssociativity $ \(x :: Int) (y :: Int) (z :: Int) ->+            add (add x y) z == add x (add y z),+          lawProperty ScalarAdditiveCommutativity $ \(x :: Int) (y :: Int) ->+            add x y == add y x,+          lawProperty ScalarAdditiveNegationInvolution $ \(x :: Int) ->+            neg (neg x) == x,+          lawProperty ScalarSubtractionDefinition $ \(x :: Int) (y :: Int) ->+            sub x y == add x (neg y)+        ],+      testGroup+        "AdditiveGroup Integer"+        [ lawProperty ScalarAdditiveLeftIdentity $ \(x :: Integer) ->+            add zero x == x,+          lawProperty ScalarAdditiveRightIdentity $ \(x :: Integer) ->+            add x zero == x,+          lawProperty ScalarAdditiveLeftInverse $ \(x :: Integer) ->+            add (neg x) x == zero,+          lawProperty ScalarAdditiveRightInverse $ \(x :: Integer) ->+            add x (neg x) == zero,+          lawProperty ScalarAdditiveAssociativity $ \(x :: Integer) (y :: Integer) (z :: Integer) ->+            add (add x y) z == add x (add y z),+          lawProperty ScalarAdditiveCommutativity $ \(x :: Integer) (y :: Integer) ->+            add x y == add y x,+          lawProperty ScalarAdditiveNegationInvolution $ \(x :: Integer) ->+            neg (neg x) == x+        ],+      testGroup+        "MultiplicativeMonoid Int"+        [ lawProperty ScalarMultiplicativeLeftIdentity $ \(x :: Int) ->+            mul one x == x,+          lawProperty ScalarMultiplicativeRightIdentity $ \(x :: Int) ->+            mul x one == x,+          lawProperty ScalarMultiplicativeAssociativity $ \(x :: Int) (y :: Int) (z :: Int) ->+            mul (mul x y) z == mul x (mul y z),+          lawProperty ScalarMultiplicativeCommutativity $ \(x :: Int) (y :: Int) ->+            mul x y == mul y x+        ],+      testGroup+        "Ring Int"+        [ lawProperty ScalarLeftDistributivity $ \(x :: Int) (y :: Int) (z :: Int) ->+            mul x (add y z) == add (mul x y) (mul x z),+          lawProperty ScalarRightDistributivity $ \(x :: Int) (y :: Int) (z :: Int) ->+            mul (add y z) x == add (mul y x) (mul z x)+        ],+      testGroup+        "AdditiveGroup Double"+        [ lawProperty ScalarAdditiveLeftIdentity $ \(x :: Double) ->+            fieldValueValid x ==> add zero x == x,+          lawProperty ScalarAdditiveRightIdentity $ \(x :: Double) ->+            fieldValueValid x ==> add x zero == x,+          lawProperty ScalarAdditiveNegationInvolution $ \(x :: Double) ->+            fieldValueValid x ==> neg (neg x) == x+        ],+      testGroup+        "MultiplicativeMonoid Double"+        [ lawProperty ScalarMultiplicativeLeftIdentity $ \(x :: Double) ->+            fieldValueValid x ==> mul one x == x,+          lawProperty ScalarMultiplicativeRightIdentity $ \(x :: Double) ->+            fieldValueValid x ==> mul x one == x+        ],+      testGroup+        "Field Double"+        [ lawProperty ScalarFieldInverseMultiplicativeIdentity fieldInverse,+          lawProperty ScalarFieldInverseResultFinite doubleInverseResultFinite,+          lawCase ScalarFieldRejectsInverseOutOfRange $+            tryInv leastPositiveSubnormalDouble @?= Nothing,+          lawCase ScalarFieldZeroNotInvertible $+            tryInv (zero :: Double) @?= Nothing,+          lawProperty ScalarFieldCanInvertAgreement $ \(x :: Double) ->+            canInvert x == isJust (tryInv x),+          lawProperty ScalarFieldRequireInvertibleAgreement $ \(x :: Double) ->+            requireInvertible () x == maybe (Left ()) Right (tryInv x),+          lawProperty ScalarFieldDivisionDefinition $ \(x :: Double) (y :: Double) ->+            fieldValueValid x ==> tryDiv x y == fmap (mul x) (tryInv y),+          lawProperty ScalarFieldDivisionByOne $ \(x :: Double) ->+            fieldValueValid x ==> tryDiv x one == Just x,+          lawCase ScalarFieldDivisionByZero $+            tryDiv (one :: Double) zero @?= Nothing+        ],+      testGroup+        "Field Float"+        [ lawProperty ScalarFieldInverseResultFinite floatInverseResultFinite,+          lawCase ScalarFieldRejectsInverseOutOfRange $+            tryInv leastPositiveSubnormalFloat @?= Nothing,+          lawCase ScalarFieldZeroNotInvertible $+            tryInv (zero :: Float) @?= Nothing+        ],+      testGroup+        "Field Rational"+        [ lawProperty ScalarFieldInverseMultiplicativeIdentity $ \(x :: Rational) ->+            x /= zero ==> fmap (mul x) (tryInv x) == Just one,+          lawCase ScalarFieldZeroNotInvertible $+            tryInv (zero :: Rational) @?= Nothing,+          lawProperty ScalarFieldDivisionDefinition $ \(x :: Rational) (y :: Rational) ->+            tryDiv x y == fmap (mul x) (tryInv y),+          lawProperty ScalarFieldDivisionByOne $ \(x :: Rational) ->+            tryDiv x one == Just x,+          lawCase ScalarFieldDivisionByZero $+            tryDiv (one :: Rational) zero @?= Nothing+        ],+      testGroup+        "Metric Double"+        [ lawCase ScalarMetricZeroMagnitude $+            magnitude (zero :: Double) @?= (zero :: Double),+          lawProperty ScalarMetricNonNegative $ \(x :: Double) ->+            fieldValueValid x ==> magnitude x >= zero,+          lawProperty ScalarMetricNegationInvariant $ \(x :: Double) ->+            fieldValueValid x ==> magnitude (neg x) == magnitude x+        ],+      testGroup+        "Metric Int"+        [ lawCase ScalarMetricZeroMagnitude $+            magnitude (zero :: Int) @?= (zero :: Int),+          lawProperty ScalarMetricNegationInvariant $ \(x :: Int) ->+            magnitude (neg x) == magnitude x+        ]+    ]++inverseResultFinite :: Field a => a -> Bool+inverseResultFinite value =+  case tryInv value of+    Just inverseValue -> fieldValueValid inverseValue+    Nothing -> True++doubleInverseResultFinite :: Double -> Bool+doubleInverseResultFinite =+  inverseResultFinite++floatInverseResultFinite :: Float -> Bool+floatInverseResultFinite =+  inverseResultFinite++leastPositiveSubnormalDouble :: Double+leastPositiveSubnormalDouble =+  encodeFloat 1 (fst (floatRange (0 :: Double)) - floatDigits (0 :: Double))++leastPositiveSubnormalFloat :: Float+leastPositiveSubnormalFloat =+  encodeFloat 1 (fst (floatRange (0 :: Float)) - floatDigits (0 :: Float))++fieldInverse :: Double -> Property+fieldInverse x = case tryInv x of+  Just xInv -> case absTol 1e-10 of+    Right tolerance -> property (approxEq tolerance (mul x xInv) one)+    Left _ -> property False+  Nothing -> property True
+ test/solver/FixpointSpec.hs view
@@ -0,0 +1,646 @@+module FixpointSpec (tests) where++import Moonlight.Core+  ( ConvergencePlan (..),+    DeltaDomain (..),+    Equation (..),+    EquationId (..),+    Evaluation,+    FixpointDivergence (..),+    Obstruction (..),+    Result,+    Snapshot (..),+    WideningPolicy (..),+    fixpointBounded,+    fixpointBoundedM,+    queueFromList,+    reachabilityFromInt,+    reschedulingWorklistFoldIntSet,+    solveIncremental,+    solveDenseMonotone,+    solveMonotone,+    planFromEquations,+    planWithConvergenceFromEquations,+    resultSnapshot,+    resultValues,+    readEquationValue,+    traverseOnceIntSet,+    worklistFold,+  )+import Data.Foldable (traverse_)+import Data.IntMap.Strict qualified as IntMap+import Data.Vector qualified as Vector+import Data.Vector.Unboxed qualified as UVector+import Moonlight.Core+  ( Edge (..),+    csrFromRows,+    csrOffsets,+    csrTargets,+    csrTranspose,+    deleteSnapshotEdge,+    sccClosureCacheFor,+    frozenDigraphFromSuccessors,+    frozenReachabilityFrom,+    frozenReachabilityWithCache,+    frozenReachabilityWithPolicy,+    graphForward,+    snapshotFromFrozen,+    snapshotReachabilityFrom,+    insertSnapshotEdge,+    mkReachabilityPolicy,+  )+import Data.IntSet qualified as IntSet+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, (@?=), assertFailure, testCase)++tests :: TestTree+tests =+  testGroup+    "bounded fixpoint"+    [ testCase "fixpointBounded reports the last pre-exhaustion state" $+        fixpointBounded 2 decreaseToZero (5 :: Int)+          @?= Left (FixpointDivergence 2 3),+      testCase "fixpointBounded returns a stable value when it converges in budget" $+        fixpointBounded 5 decreaseToZero (3 :: Int)+          @?= Right 0,+      testCase "fixpointBoundedM returns typed divergence through monadic steps" $+        (fixpointBoundedM 2 (Right . decreaseToZero) (5 :: Int) :: Either String (Either (FixpointDivergence Int) Int))+          @?= Right (Left (FixpointDivergence 2 3)),+      testCase "worklistFold preserves FIFO frontier order" $+        reverse+          (worklistFold step [] (queueFromList [0 :: Int]))+          @?= [0, 1, 2],+      testCase "traverseOnceIntSet processes each key once through a fresh frontier" $+        traverseOnceIntSet intSetStep [] (IntSet.singleton 0)+          @?= [2, 1, 0],+      testCase "reschedulingWorklistFoldIntSet reruns a dequeued key" $+        IntMap.findWithDefault 0 0 (reschedulingWorklistFoldIntSet rescheduleSelf IntMap.empty (IntSet.singleton 0))+          @?= 2,+      testCase "reschedulingWorklistFoldIntSet deduplicates keys while queued" $+        reverse (reschedulingWorklistFoldIntSet enqueueSharedKey [] (IntSet.fromList [0, 2]))+          @?= [0, 2, 1],+      testCase "solveMonotone propagates through a cyclic monotone component" $+        fmap resultValues (solveCyclicPropagation initialCycleValues)+          @?= Right propagatedCycleValues,+      testCase "solveMonotone full snapshot evaluates a chain after dependencies" $+        assertFullSnapshotDependencyClosure 3 chainDependencySuccessors,+      testCase "solveMonotone full snapshot evaluates a diamond after dependencies" $+        assertFullSnapshotDependencyClosure 4 diamondDependencySuccessors,+      testCase "plan construction rejects an equation id at or beyond the declared capacity" $+        fmap+          resultValues+          ( planFromEquations 1 cyclicPropagationEquations+              >>= \plan -> solveMonotone intSetDeltaDomain plan initialCycleValues+          )+          @?= Left (EquationIdExceedsCapacity (EquationId 1) 1),+      testCase "solver snapshots must exactly match plan capacity" $+        case planFromEquations 1 ([] :: [Equation Int Int]) of+          Left obstruction ->+            assertFailure ("empty exact-capacity plan failed: " <> show obstruction)+          Right plan ->+            ( fmap resultValues (solveMonotone intGrowthDeltaDomain plan Vector.empty),+              fmap resultValues (solveMonotone intGrowthDeltaDomain plan (Vector.fromList [0, 1]))+            )+              @?= (Left (SnapshotSizeMismatch 1 0), Left (SnapshotSizeMismatch 1 2)),+      testCase "solver deltas are bounded by plan capacity" $+        case planFromEquations 1 ([] :: [Equation Int Int]) of+          Left obstruction ->+            assertFailure ("empty exact-capacity plan failed: " <> show obstruction)+          Right plan ->+            fmap resultValues+              (solveIncremental intGrowthDeltaDomain plan (Snapshot (Vector.singleton 0)) (IntMap.singleton 1 5))+              @?= Left (DeltaOutOfBounds (EquationId 1) 1),+      testCase "dense plans reject reads outside their declared capacity" $+        fmap resultValues+          (solveDenseMonotone intGrowthDeltaDomain 1 (const (readEquationValue (EquationId 1))) (const 0))+          @?= Left (EquationIdExceedsCapacity (EquationId 1) 1),+      testCase "solveIncremental reuses a snapshot and propagates new deltas through the cycle" $+        case planFromEquations 2 cyclicPropagationEquations of+          Left obstruction ->+            assertFailure ("cyclic propagation plan failed: " <> show obstruction)+          Right plan ->+            case solveMonotone intSetDeltaDomain plan initialCycleValues of+              Left obstruction ->+                assertFailure ("initial cyclic solve failed: " <> show obstruction)+              Right firstResult ->+                fmap resultValues+                  ( solveIncremental+                      intSetDeltaDomain+                      plan+                      (resultSnapshot firstResult)+                      (IntMap.singleton 0 (IntSet.singleton 7))+                  )+                  @?= Right incrementalCycleValues,+      testCase "solveIncremental agrees with full recomputation after input growth" $+        case planFromEquations 2 cyclicPropagationEquations of+          Left obstruction ->+            assertFailure ("cyclic propagation plan failed: " <> show obstruction)+          Right plan ->+            case solveMonotone intSetDeltaDomain plan initialCycleValues of+              Left obstruction ->+                assertFailure ("initial cyclic solve failed: " <> show obstruction)+              Right firstResult ->+                fmap resultValues+                  ( solveIncremental+                      intSetDeltaDomain+                      plan+                      (resultSnapshot firstResult)+                      (IntMap.singleton 0 (IntSet.singleton 7))+                  )+                  @?= fmap resultValues (solveMonotone intSetDeltaDomain plan fullRecomputeCycleValues),+      testCase "evaluation reads author the dependency plan used by incremental solving" $+        case planFromEquations 2 [derivedDependencyEquation] of+          Left obstruction ->+            assertFailure ("derived dependency plan failed: " <> show obstruction)+          Right plan ->+            fmap resultValues+              ( solveIncremental+                  intGrowthDeltaDomain+                  plan+                  (Snapshot (Vector.fromList [0, 0]))+                  (IntMap.singleton 0 7)+              )+              @?= fmap resultValues+                (solveMonotone intGrowthDeltaDomain plan (Vector.fromList [7, 0])),+      testCase "solveIncremental uses derivatives to propagate through acyclic users" $+        case planFromEquations 3 acyclicDerivativeEquations of+          Left obstruction ->+            assertFailure ("acyclic derivative plan failed: " <> show obstruction)+          Right plan ->+            fmap resultValues+              ( solveIncremental+                  intSetDeltaDomain+                  plan+                  (Snapshot solvedAcyclicDerivativeValues)+                  (IntMap.singleton 0 (IntSet.singleton 7))+              )+              @?= Right incrementedAcyclicDerivativeValues,+      testCase "solveIncremental ignores saturated external seed deltas" $+        case planFromEquations 2 [cappedSeedPropagationEquation] of+          Left obstruction ->+            assertFailure ("capped seed propagation plan failed: " <> show obstruction)+          Right plan ->+            fmap resultValues+              ( solveIncremental+                  cappedIntDeltaDomain+                  plan+                  (Snapshot cappedSeedSnapshotValues)+                  (IntMap.singleton 0 5)+              )+              @?= Right cappedSeedSnapshotValues,+      testCase "Widening applies the explicit widening head callback" $+        case planWithConvergenceFromEquations wideningPlan 1 [wideningGrowthEquation] of+          Left obstruction ->+            assertFailure ("widening plan failed: " <> show obstruction)+          Right plan ->+            fmap resultValues+              (solveMonotone intGrowthDeltaDomain plan (Vector.singleton 0))+              @?= Right (Vector.singleton 100),+      testCase "CSR construction consumes only its declared row prefix" $+        let csr = csrFromRows 2 ([[1], [0]] <> error "discarded CSR tail was forced")+         in (csrOffsets csr, csrTargets csr)+              @?= (UVector.fromList [0, 1, 2], UVector.fromList [1, 0]),+      testCase "CSR construction pads short inputs and ignores long suffixes" $+        let shortCsr = csrFromRows 3 [[2]]+            longCsr = csrFromRows 2 [[1], [0], [99]]+         in (csrOffsets shortCsr, csrTargets shortCsr, csrOffsets longCsr, csrTargets longCsr)+              @?= (UVector.fromList [0, 1, 1, 1], UVector.singleton 2, UVector.fromList [0, 1, 2], UVector.fromList [1, 0]),+      testCase "CSR construction deduplicates and sorts row targets" $+        let csr = csrFromRows 1 [[3, 1, 3, 2]]+         in csrTargets csr @?= UVector.fromList [1, 2, 3],+      testCase "CSR transpose reverses every edge and retains isolated vertices" $+        let transposed =+              csrTranspose+                (graphForward (frozenDigraphFromSuccessors 5 transposeFixtureSuccessors))+         in (csrOffsets transposed, csrTargets transposed)+              @?= (UVector.fromList [0, 1, 3, 3, 5, 5], UVector.fromList [3, 0, 4, 0, 1]),+      testCase "CSR transpose is involutive after ingress normalization" $+        let forward =+              graphForward (frozenDigraphFromSuccessors 3 normalizedTransposeFixtureSuccessors)+         in csrTranspose (csrTranspose forward) @?= forward,+      testCase "CSR transpose is total for empty and isolated graphs" $+        let emptyForward = graphForward (frozenDigraphFromSuccessors 0 (const IntSet.empty))+            isolatedForward = graphForward (frozenDigraphFromSuccessors 3 (const IntSet.empty))+         in (csrTranspose emptyForward, csrTranspose isolatedForward)+              @?= (emptyForward, isolatedForward),+      testCase "CSR reachability agrees with IntSet closure through an SCC" $+        frozenReachabilityFrom (frozenDigraphFromSuccessors 4 graphStep) (IntSet.singleton 0)+          @?= reachabilityFromInt graphStep (IntSet.singleton 0),+      testCase "CSR reachability agrees with IntSet closure across topology and seed matrix" $+        traverse_ assertReachabilityCase reachabilityCases,+      testCase "CSR policy variants and hot SCC cache preserve cold reachability" $+        assertPolicyAndCacheReachabilityCase,+      testCase "SCC caches are constructed for exactly one frozen graph" $+        assertSccCacheGraphOwnership,+      testCase "graph snapshot semantic no-ops preserve the original snapshot" $+        assertGraphSnapshotNoOps,+      testCase "graph snapshot overlay and tombstones agree with IntSet closure" $+        snapshotReachabilityFrom editedSnapshot (IntSet.singleton 0)+          @?= reachabilityFromInt editedGraphStep (IntSet.singleton 0)+    ]+  where+    step :: [Int] -> Int -> ([Int], [Int])+    step seen current =+      ( current : seen,+        case current of+          0 -> [1, 2]+          _ -> []+      )++    intSetStep :: [Int] -> Int -> ([Int], IntSet.IntSet)+    intSetStep seen current =+      ( current : seen,+        case current of+          0 -> IntSet.fromList [0, 1]+          1 -> IntSet.fromList [0, 2]+          _ -> IntSet.empty+      )++    rescheduleSelf :: IntMap.IntMap Int -> Int -> (IntMap.IntMap Int, IntSet.IntSet)+    rescheduleSelf visits current =+      ( nextVisits,+        if current == 0 && visitCount == 0+          then IntSet.singleton 0+          else IntSet.empty+      )+      where+        visitCount =+          IntMap.findWithDefault 0 current visits+        nextVisits =+          IntMap.insert current (visitCount + 1) visits++    enqueueSharedKey :: [Int] -> Int -> ([Int], IntSet.IntSet)+    enqueueSharedKey seen current =+      ( current : seen,+        case current of+          0 -> IntSet.singleton 1+          2 -> IntSet.singleton 1+          _ -> IntSet.empty+      )++    graphStep :: Int -> IntSet.IntSet+    graphStep current =+      case current of+        0 -> IntSet.singleton 1+        1 -> IntSet.fromList [0, 2]+        2 -> IntSet.singleton 3+        _ -> IntSet.empty++    transposeFixtureSuccessors :: Int -> IntSet.IntSet+    transposeFixtureSuccessors source =+      case source of+        0 -> IntSet.fromList [1, 3]+        1 -> IntSet.singleton 3+        3 -> IntSet.singleton 0+        4 -> IntSet.singleton 1+        _ -> IntSet.empty++    normalizedTransposeFixtureSuccessors :: Int -> IntSet.IntSet+    normalizedTransposeFixtureSuccessors source =+      case source of+        0 -> IntSet.fromList [-1, 1, 1, 3]+        1 -> IntSet.singleton 2+        2 -> IntSet.singleton 0+        _ -> IntSet.empty++    assertReachabilityCase (vertexCount, seeds, expand) =+      frozenReachabilityFrom (frozenDigraphFromSuccessors vertexCount expand) seeds+        @?= reachabilityFromInt expand seeds++    assertPolicyAndCacheReachabilityCase =+      case (mkReachabilityPolicy 1.0e100 1.0e100 maxBound, mkReachabilityPolicy 0 0 0) of+        (Right sparsePushOnlyPolicy, Right densePullBiasedPolicy) ->+          let graph =+                frozenDigraphFromSuccessors 96 (sccHeavySuccessors 96)+              seeds =+                IntSet.fromList [0, 8, 16]+              cold =+                frozenReachabilityFrom graph seeds+              sparse =+                frozenReachabilityWithPolicy sparsePushOnlyPolicy graph seeds+              dense =+                frozenReachabilityWithPolicy densePullBiasedPolicy graph seeds+              coldCache =+                sccClosureCacheFor graph+              (firstCached, cache1) =+                frozenReachabilityWithCache coldCache seeds+              (hotCached, _cache2) =+                frozenReachabilityWithCache cache1 seeds+           in (sparse, dense, firstCached, hotCached) @?= (cold, cold, cold, cold)+        (Left policyError, _) ->+          assertFailure ("sparse policy construction failed: " <> show policyError)+        (_, Left policyError) ->+          assertFailure ("dense policy construction failed: " <> show policyError)++    assertSccCacheGraphOwnership =+      let seeds =+            IntSet.singleton 1+          graphWithEdge =+            frozenDigraphFromSuccessors 2 graphWithBackwardEdge+          graphWithoutEdge =+            frozenDigraphFromSuccessors 2 (const IntSet.empty)+          cacheWithEdge =+            sccClosureCacheFor graphWithEdge+          (_firstReachable, warmedCache) =+            frozenReachabilityWithCache cacheWithEdge seeds+          (_hotReachable, hotCache) =+            frozenReachabilityWithCache warmedCache seeds+          cacheWithoutEdge =+            sccClosureCacheFor graphWithoutEdge+          (withoutEdgeReachable, _coldCache) =+            frozenReachabilityWithCache cacheWithoutEdge seeds+          (withEdgeReachable, _stillBoundCache) =+            frozenReachabilityWithCache hotCache seeds+       in (withoutEdgeReachable, withEdgeReachable)+            @?= (frozenReachabilityFrom graphWithoutEdge seeds, frozenReachabilityFrom graphWithEdge seeds)++    graphWithBackwardEdge :: Int -> IntSet.IntSet+    graphWithBackwardEdge current =+      case current of+        1 -> IntSet.singleton 0+        _ -> IntSet.empty++    assertGraphSnapshotNoOps =+      let graph =+            frozenDigraphFromSuccessors 2 graphWithBackwardEdge+          snapshot =+            snapshotFromFrozen graph+       in ( insertSnapshotEdge (Edge 1 0) snapshot,+            insertSnapshotEdge (Edge 0 2) snapshot,+            deleteSnapshotEdge (Edge 0 1) snapshot,+            deleteSnapshotEdge (Edge (-1) 0) snapshot+          )+            @?= (snapshot, snapshot, snapshot, snapshot)++    reachabilityCases =+      [ (16, IntSet.singleton 0, chainSuccessors 16),+        (32, IntSet.fromList [0, 3, 7], fanoutSuccessors 4 32),+        (36, IntSet.fromList [0, 5], gridSuccessors 6 36),+        (64, IntSet.singleton 0, powerLawLikeSuccessors 64),+        (48, IntSet.fromList [0, 16, 32], sccHeavySuccessors 48)+      ]++    chainSuccessors size current =+      IntSet.fromAscList (filter (< size) [current + 1])++    fanoutSuccessors degree size current =+      IntSet.fromAscList (filter (< size) [current + 1 .. current + degree])++    gridSuccessors width size current =+      IntSet.fromList (filter (< size) (rightNeighbor <> downNeighbor))+      where+        rightNeighbor =+          [current + 1 | current `mod` width /= width - 1]+        downNeighbor =+          [current + width]++    powerLawLikeSuccessors size current =+      IntSet.fromList (filter (< size) (fmap (current +) (takeWhile (< size) powersOfTwo)))+      where+        powersOfTwo =+          take (1 + current `mod` 6) (iterate (* 2) 1)++    sccHeavySuccessors size current =+      IntSet.fromList (filter (< size) [cycleNeighbor, current + componentSize])+      where+        componentSize =+          8+        componentStart =+          current - current `mod` componentSize+        cycleNeighbor =+          componentStart + ((current + 1) `mod` componentSize)++    editedSnapshot =+      deleteSnapshotEdge (Edge 1 2) $+        insertSnapshotEdge (Edge 4 5) $+          insertSnapshotEdge (Edge 0 4) $+            snapshotFromFrozen (frozenDigraphFromSuccessors 6 editedBaseGraphStep)++    editedBaseGraphStep :: Int -> IntSet.IntSet+    editedBaseGraphStep current =+      case current of+        0 -> IntSet.singleton 1+        1 -> IntSet.singleton 2+        2 -> IntSet.singleton 3+        _ -> IntSet.empty++    editedGraphStep :: Int -> IntSet.IntSet+    editedGraphStep current =+      case current of+        0 -> IntSet.fromList [1, 4]+        4 -> IntSet.singleton 5+        _ -> IntSet.empty++decreaseToZero :: Int -> Int+decreaseToZero current =+  if current <= 0+    then 0+    else current - 1++intSetDeltaDomain :: DeltaDomain IntSet.IntSet IntSet.IntSet+intSetDeltaDomain =+  DeltaDomain+    { deltaEmpty = IntSet.empty,+      deltaNull = IntSet.null,+      deltaMerge = IntSet.union,+      deltaApply = IntSet.union,+      deltaBetween = \oldValue newValue -> IntSet.difference newValue oldValue+    }++initialCycleValues :: Vector.Vector IntSet.IntSet+initialCycleValues =+  Vector.fromList [IntSet.singleton 0, IntSet.empty]++propagatedCycleValues :: Vector.Vector IntSet.IntSet+propagatedCycleValues =+  Vector.fromList [IntSet.singleton 0, IntSet.singleton 0]++incrementalCycleValues :: Vector.Vector IntSet.IntSet+incrementalCycleValues =+  Vector.fromList [IntSet.fromList [0, 7], IntSet.fromList [0, 7]]++fullRecomputeCycleValues :: Vector.Vector IntSet.IntSet+fullRecomputeCycleValues =+  Vector.fromList [IntSet.fromList [0, 7], IntSet.empty]++solvedAcyclicDerivativeValues :: Vector.Vector IntSet.IntSet+solvedAcyclicDerivativeValues =+  Vector.fromList [IntSet.singleton 0, IntSet.singleton 0, IntSet.singleton 0]++incrementedAcyclicDerivativeValues :: Vector.Vector IntSet.IntSet+incrementedAcyclicDerivativeValues =+  Vector.fromList [IntSet.fromList [0, 7], IntSet.fromList [0, 7], IntSet.fromList [0, 7]]++cappedSeedSnapshotValues :: Vector.Vector Int+cappedSeedSnapshotValues =+  Vector.fromList [10, 0]++cappedIntDeltaDomain :: DeltaDomain Int Int+cappedIntDeltaDomain =+  DeltaDomain+    { deltaEmpty = 0,+      deltaNull = (== 0),+      deltaMerge = max,+      deltaApply = \deltaValue oldValue -> min 10 (oldValue + deltaValue),+      deltaBetween = \oldValue newValue -> max 0 (newValue - oldValue)+    }++cappedSeedPropagationEquation :: Equation Int Int+cappedSeedPropagationEquation =+  Equation+    { equationOutput = EquationId 1,+      evaluateFull = solverIntValue 0,+      evaluateDelta =+        Just+          ( \changedInput inputDelta ->+              if changedInput == EquationId 0+                then inputDelta+                else 0+          )+    }++solveCyclicPropagation ::+  Vector.Vector IntSet.IntSet ->+  Either Obstruction (Result IntSet.IntSet IntSet.IntSet)+solveCyclicPropagation values =+  planFromEquations 2 cyclicPropagationEquations+    >>= \plan -> solveMonotone intSetDeltaDomain plan values++assertFullSnapshotDependencyClosure ::+  Int ->+  (Int -> IntSet.IntSet) ->+  Assertion+assertFullSnapshotDependencyClosure valueCount successors =+  case planFromEquations valueCount (dependencyPropagationEquations valueCount successors) of+    Left obstruction ->+      assertFailure ("dependency propagation plan failed: " <> show obstruction)+    Right plan ->+      fmap resultValues+        (solveMonotone intSetDeltaDomain plan (singletonDependencyValues valueCount))+        @?= Right (expectedDependencyClosureValues valueCount successors)++dependencyPropagationEquations ::+  Int ->+  (Int -> IntSet.IntSet) ->+  [Equation IntSet.IntSet IntSet.IntSet]+dependencyPropagationEquations valueCount successors =+  [ propagationEquation target source+    | source <- [0 .. valueCount - 1],+      target <- IntSet.toAscList (successors source)+  ]++singletonDependencyValues :: Int -> Vector.Vector IntSet.IntSet+singletonDependencyValues valueCount =+  Vector.generate valueCount IntSet.singleton++expectedDependencyClosureValues ::+  Int ->+  (Int -> IntSet.IntSet) ->+  Vector.Vector IntSet.IntSet+expectedDependencyClosureValues valueCount successors =+  Vector.generate valueCount ancestorsOf+  where+    ancestorsOf target =+      IntSet.fromList+        [ source+          | source <- [0 .. valueCount - 1],+            IntSet.member target (reachabilityFromInt successors (IntSet.singleton source))+        ]++chainDependencySuccessors :: Int -> IntSet.IntSet+chainDependencySuccessors source =+  case source of+    0 -> IntSet.singleton 1+    1 -> IntSet.singleton 2+    _ -> IntSet.empty++diamondDependencySuccessors :: Int -> IntSet.IntSet+diamondDependencySuccessors source =+  case source of+    0 -> IntSet.fromList [1, 2]+    1 -> IntSet.singleton 3+    2 -> IntSet.singleton 3+    _ -> IntSet.empty++cyclicPropagationEquations :: [Equation IntSet.IntSet IntSet.IntSet]+cyclicPropagationEquations =+  [ propagationEquation 0 1,+    propagationEquation 1 0+  ]++acyclicDerivativeEquations :: [Equation IntSet.IntSet IntSet.IntSet]+acyclicDerivativeEquations =+  [ derivativeOnlyPropagationEquation 1 0,+    derivativeOnlyPropagationEquation 2 1+  ]++propagationEquation :: Int -> Int -> Equation IntSet.IntSet IntSet.IntSet+propagationEquation output input =+  Equation+    { equationOutput = EquationId output,+      evaluateFull = solverIntSetValue input,+      evaluateDelta =+        Just+          ( \changedInput inputDelta ->+              if changedInput == EquationId input+                then inputDelta+                else IntSet.empty+          )+    }++derivativeOnlyPropagationEquation :: Int -> Int -> Equation IntSet.IntSet IntSet.IntSet+derivativeOnlyPropagationEquation output input =+  Equation+    { equationOutput = EquationId output,+      evaluateFull = IntSet.singleton 999 <$ readEquationValue (EquationId input),+      evaluateDelta =+        Just+          ( \changedInput inputDelta ->+              if changedInput == EquationId input+                then inputDelta+                else IntSet.empty+          )+    }++solverIntSetValue :: Int -> Evaluation IntSet.IntSet IntSet.IntSet+solverIntSetValue key =+  readEquationValue (EquationId key)++derivedDependencyEquation :: Equation Int Int+derivedDependencyEquation =+  Equation+    { equationOutput = EquationId 1,+      evaluateFull = solverIntValue 0,+      evaluateDelta = Nothing+    }++intGrowthDeltaDomain :: DeltaDomain Int Int+intGrowthDeltaDomain =+  DeltaDomain+    { deltaEmpty = 0,+      deltaNull = (== 0),+      deltaMerge = max,+      deltaApply = (+),+      deltaBetween = \oldValue newValue -> max 0 (newValue - oldValue)+    }++wideningPlan :: ConvergencePlan Int+wideningPlan =+  Widening+    WideningPolicy+      { wideningHeads = IntSet.singleton 0,+        widenAt = \_key _oldValue _newValue -> 100,+        narrowAt = \_key _oldValue newValue -> newValue+      }++wideningGrowthEquation :: Equation Int Int+wideningGrowthEquation =+  Equation+    { equationOutput = EquationId 0,+      evaluateFull = min 10 . (+ 1) <$> solverIntValue 0,+      evaluateDelta = Nothing+    }++solverIntValue :: Int -> Evaluation Int Int+solverIntValue key =+  readEquationValue (EquationId key)
+ test/solver/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import qualified SolverTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain SolverTests.tests
+ test/solver/SolverTests.hs view
@@ -0,0 +1,16 @@+module SolverTests+  ( tests,+  )+where++import qualified FixpointSpec as FixpointSpec+import qualified UnionFindSpec as UnionFindSpec+import Test.Tasty (TestTree, testGroup)++tests :: TestTree+tests =+  testGroup+    "moonlight-core-solver"+    [ FixpointSpec.tests,+      UnionFindSpec.tests+    ]
+ test/solver/UnionFindSpec.hs view
@@ -0,0 +1,552 @@+module UnionFindSpec+  ( tests,+  )+where++import Control.Monad+  ( foldM,+  )+import Control.Monad.ST+  ( ST,+  )+import Data.Foldable+  ( traverse_,+  )+import Data.IntMap.Strict+  ( IntMap,+  )+import Data.IntMap.Strict qualified as IntMap+import Moonlight.Core+  ( ClassId (..),+  )+import Moonlight.Core+  ( UnionFind,+    UnionFindAllocationError (..),+  )+import Moonlight.Core qualified as UnionFind+import Moonlight.Core qualified as Transaction+import Test.Tasty+  ( TestTree,+    testGroup,+  )+import Test.Tasty.HUnit+  ( Assertion,+    assertBool,+    assertEqual,+    assertFailure,+    testCase,+  )+import Test.Tasty.QuickCheck qualified as QuickCheck+import Prelude++data Operation+  = InsertClass !Int+  | FindClass !Int+  | FindExistingClass !Int+  | CanonicalClass !Int+  | ClassesEquivalent !Int !Int+  | UnionClasses !Int !Int+  | MakeSet+  | CompressCanonicalMap+  deriving stock (Eq, Show)++newtype OperationTrace = OperationTrace+  { unOperationTrace :: [Operation]+  }+  deriving stock (Eq, Show)++data TraceSeed+  = EmptySeed+  | DensePrefixSeed+  | HoleyPrefixSeed+  | NegativeSparseSeed+  | GiantOutlierSeed+  | PrelinkedDenseSparseSeed+  deriving stock (Bounded, Enum, Eq, Show)++data Observation+  = ObservedUnit+  | ObservedClass !ClassId+  | ObservedMaybeClass !(Maybe ClassId)+  | ObservedAllocation !(Either UnionFindAllocationError ClassId)+  | ObservedBool !Bool+  | ObservedCanonicalMap ![(Int, ClassId)]+  deriving stock (Eq, Show)++instance QuickCheck.Arbitrary Operation where+  arbitrary =+    QuickCheck.frequency+      [ (4, InsertClass <$> arbitraryClassKey),+        (8, FindClass <$> arbitraryClassKey),+        (4, FindExistingClass <$> arbitraryClassKey),+        (4, CanonicalClass <$> arbitraryClassKey),+        (4, ClassesEquivalent <$> arbitraryClassKey <*> arbitraryClassKey),+        (8, UnionClasses <$> arbitraryClassKey <*> arbitraryClassKey),+        (1, pure MakeSet),+        (1, pure CompressCanonicalMap)+      ]++  shrink operation =+    case operation of+      InsertClass key ->+        InsertClass <$> QuickCheck.shrink key+      FindClass key ->+        FindClass <$> QuickCheck.shrink key+      FindExistingClass key ->+        FindExistingClass <$> QuickCheck.shrink key+      CanonicalClass key ->+        CanonicalClass <$> QuickCheck.shrink key+      ClassesEquivalent leftKey rightKey ->+        uncurry ClassesEquivalent <$> QuickCheck.shrink (leftKey, rightKey)+      UnionClasses leftKey rightKey ->+        uncurry UnionClasses <$> QuickCheck.shrink (leftKey, rightKey)+      MakeSet ->+        []+      CompressCanonicalMap ->+        []++instance QuickCheck.Arbitrary OperationTrace where+  arbitrary =+    QuickCheck.sized $ \size -> do+      operationCount <-+        QuickCheck.chooseInt+          (0, min 200 (2 * size + 1))+      OperationTrace+        <$> QuickCheck.vectorOf+          operationCount+          QuickCheck.arbitrary++  shrink (OperationTrace operations) =+    OperationTrace <$> QuickCheck.shrinkList QuickCheck.shrink operations++instance QuickCheck.Arbitrary TraceSeed where+  arbitrary =+    QuickCheck.elements [minBound .. maxBound]++tests :: TestTree+tests =+  testGroup+    "union-find"+    [ QuickCheck.testProperty+        "transaction exactly matches persistent operation traces"+        transactionMatchesPersistent,+      testCase+        "equal-rank union chooses the smaller representative"+        equalRankRepresentativeIsDeterministic,+      testCase+        "transactional union reports named merge roots"+        transactionalUnionReportsMergeRoots,+      testCase+        "prefix and giant sparse outlier interoperate"+        prefixOutlierCrossLink,+      testCase+        "canonical compression is exact and idempotent"+        canonicalCompressionIsIdempotent,+      testCase+        "samePartition ignores representative history"+        samePartitionIgnoresRepresentativeHistory,+      testCase+        "an aborted transaction publishes no snapshot"+        abortedTransactionDoesNotCommit,+      testCase+        "union inserts absent class identifiers"+        unionInsertsAbsentClassIdentifiers,+      testCase+        "makeSet does not overwrite relationships introduced by union"+        makeSetPreservesUnionIntroducedRelationships,+      testCase+        "persistent allocation exhaustion preserves the partition"+        persistentAllocationExhaustionPreservesPartition,+      testCase+        "transactional allocation exhaustion preserves the partition"+        transactionalAllocationExhaustionPreservesPartition,+      testCase+        "allocation starts at zero and ignores negative sparse ids"+        ordinaryAllocationSequenceIsStable+    ]++transactionMatchesPersistent ::+  TraceSeed ->+  OperationTrace ->+  QuickCheck.Property+transactionMatchesPersistent seed trace =+  let persistentResult =+        runPersistentTraceFrom (unionFindSeed seed) trace+      transactionResult =+        runTransactionTraceFrom (unionFindSeed seed) trace+   in QuickCheck.counterexample+        ( "seed: "+            <> show seed+            <> "\npersistent: "+            <> show persistentResult+            <> "\ntransaction: "+            <> show transactionResult+        )+        (sameTraceResult persistentResult transactionResult)++runPersistentTraceFrom ::+  UnionFind ->+  OperationTrace ->+  ([Observation], UnionFind)+runPersistentTraceFrom base (OperationTrace operations) =+  let (reverseObservations, finalUnionFind) =+        foldl'+          persistentStep+          ([], base)+          operations+   in (reverse reverseObservations, finalUnionFind)++persistentStep ::+  ([Observation], UnionFind) ->+  Operation ->+  ([Observation], UnionFind)+persistentStep (observations, unionFind) operation =+  case operation of+    InsertClass key ->+      ( ObservedUnit : observations,+        UnionFind.insertClassId (ClassId key) unionFind+      )+    FindClass key ->+      let (rootClass, unionFind') =+            UnionFind.find (ClassId key) unionFind+       in ( ObservedClass rootClass : observations,+            unionFind'+          )+    FindExistingClass key ->+      case UnionFind.findExisting (ClassId key) unionFind of+        Nothing ->+          (ObservedMaybeClass Nothing : observations, unionFind)+        Just (rootClass, unionFind') ->+          (ObservedMaybeClass (Just rootClass) : observations, unionFind')+    CanonicalClass key ->+      ( ObservedMaybeClass (UnionFind.canonicalClass (ClassId key) unionFind) : observations,+        unionFind+      )+    ClassesEquivalent leftKey rightKey ->+      ( ObservedBool (UnionFind.equivalent (ClassId leftKey) (ClassId rightKey) unionFind) : observations,+        unionFind+      )+    UnionClasses leftKey rightKey ->+      ( ObservedUnit : observations,+        UnionFind.union (ClassId leftKey) (ClassId rightKey) unionFind+      )+    MakeSet ->+      case UnionFind.makeSet unionFind of+        Left allocationError ->+          (ObservedAllocation (Left allocationError) : observations, unionFind)+        Right (classId, unionFind') ->+          (ObservedAllocation (Right classId) : observations, unionFind')+    CompressCanonicalMap ->+      let (parents, unionFind') =+            UnionFind.canonicalMapAndCompress unionFind+       in (observeCanonicalMap parents : observations, unionFind')++runTransactionTraceFrom ::+  UnionFind ->+  OperationTrace ->+  ([Observation], UnionFind)+runTransactionTraceFrom base (OperationTrace operations) =+  let (reverseObservations, finalUnionFind) =+        Transaction.runUnionFindTransaction+          base+          (\editor -> foldM (transactionStep editor) [] operations)+   in (reverse reverseObservations, finalUnionFind)++transactionStep ::+  Transaction.UnionFindEditor state ->+  [Observation] ->+  Operation ->+  ST state [Observation]+transactionStep editor observations operation =+  case operation of+    InsertClass key -> do+      Transaction.transactionInsertClassId editor (ClassId key)+      pure (ObservedUnit : observations)+    FindClass key -> do+      rootClass <- Transaction.transactionFind editor (ClassId key)+      pure (ObservedClass rootClass : observations)+    FindExistingClass key -> do+      maybeRoot <- Transaction.transactionFindExisting editor (ClassId key)+      pure (ObservedMaybeClass maybeRoot : observations)+    CanonicalClass key -> do+      maybeRoot <- Transaction.transactionCanonicalClass editor (ClassId key)+      pure (ObservedMaybeClass maybeRoot : observations)+    ClassesEquivalent leftKey rightKey -> do+      result <- Transaction.transactionEquivalent editor (ClassId leftKey) (ClassId rightKey)+      pure (ObservedBool result : observations)+    UnionClasses leftKey rightKey -> do+      _ <- Transaction.transactionUnion editor (ClassId leftKey) (ClassId rightKey)+      pure (ObservedUnit : observations)+    MakeSet -> do+      allocation <- Transaction.transactionMakeSet editor+      pure (ObservedAllocation allocation : observations)+    CompressCanonicalMap -> do+      parents <- Transaction.transactionCanonicalMapAndCompress editor+      pure (observeCanonicalMap parents : observations)++observeCanonicalMap ::+  IntMap ClassId ->+  Observation+observeCanonicalMap =+  ObservedCanonicalMap . IntMap.toAscList++sameTraceResult ::+  ([Observation], UnionFind) ->+  ([Observation], UnionFind) ->+  Bool+sameTraceResult (leftObservations, leftUnionFind) (rightObservations, rightUnionFind) =+  leftObservations == rightObservations+    && UnionFind.samePartition leftUnionFind rightUnionFind++assertSameTraceResult ::+  String ->+  ([Observation], UnionFind) ->+  ([Observation], UnionFind) ->+  Assertion+assertSameTraceResult label (expectedObservations, expectedUnionFind) (actualObservations, actualUnionFind) = do+  assertEqual+    (label <> " observations")+    expectedObservations+    actualObservations+  assertBool+    (label <> " partition")+    (UnionFind.samePartition expectedUnionFind actualUnionFind)++arbitraryClassKey :: QuickCheck.Gen Int+arbitraryClassKey =+  QuickCheck.frequency+    [ (12, QuickCheck.chooseInt (-128, 1024)),+      (3, (* 17) <$> QuickCheck.chooseInt (-4096, 4096)),+      ( 1,+        QuickCheck.elements+          [ minBound,+            -1000000000,+            1000000000,+            maxBound+          ]+      )+    ]++unionFindSeed :: TraceSeed -> UnionFind+unionFindSeed seed =+  case seed of+    EmptySeed ->+      UnionFind.emptyUnionFind+    DensePrefixSeed ->+      UnionFind.fromClassIds (ClassId <$> [0 .. 127])+    HoleyPrefixSeed ->+      UnionFind.fromClassIds (ClassId <$> [0, 2 .. 254])+    NegativeSparseSeed ->+      UnionFind.fromClassIds (ClassId . negate <$> [1 .. 128])+    GiantOutlierSeed ->+      UnionFind.fromClassIds (ClassId <$> ([0 .. 63] <> [1000000000]))+    PrelinkedDenseSparseSeed ->+      UnionFind.union+        (ClassId 1000000000)+        (ClassId 0)+        (UnionFind.fromClassIds (ClassId <$> ([0 .. 127] <> [-7])))++equalRankRepresentativeIsDeterministic :: Assertion+equalRankRepresentativeIsDeterministic = do+  let unionFind =+        UnionFind.union+          (ClassId 9)+          (ClassId 3)+          UnionFind.emptyUnionFind+  assertEqual+    "canonical roots"+    (Just (ClassId 3), Just (ClassId 3))+    ( UnionFind.canonicalClass (ClassId 9) unionFind,+      UnionFind.canonicalClass (ClassId 3) unionFind+    )++transactionalUnionReportsMergeRoots :: Assertion+transactionalUnionReportsMergeRoots = do+  let (outcomes, committedUnionFind) =+        Transaction.runUnionFindTransaction UnionFind.emptyUnionFind $ \editor -> do+          firstUnion <- Transaction.transactionUnion editor (ClassId 9) (ClassId 4)+          secondUnion <- Transaction.transactionUnion editor (ClassId 9) (ClassId 4)+          pure (firstUnion, secondUnion)+  assertEqual+    "union outcome"+    (Transaction.MergedClasses (ClassId 4) (ClassId 9), Transaction.AlreadyEquivalent (ClassId 4))+    outcomes+  assertBool+    "committed partition"+    ( UnionFind.samePartition+        (UnionFind.union (ClassId 9) (ClassId 4) UnionFind.emptyUnionFind)+        committedUnionFind+    )++prefixOutlierCrossLink :: Assertion+prefixOutlierCrossLink = do+  let outlier =+        1000000000+      operations =+        OperationTrace+          ( fmap InsertClass [0 .. 255]+              <> [ InsertClass outlier,+                   UnionClasses outlier 0,+                   FindClass outlier,+                   FindClass 0,+                   CompressCanonicalMap+                 ]+          )+  assertSameTraceResult+    "transaction preserves observations and partition"+    (runPersistentTraceFrom UnionFind.emptyUnionFind operations)+    (runTransactionTraceFrom UnionFind.emptyUnionFind operations)++canonicalCompressionIsIdempotent :: Assertion+canonicalCompressionIsIdempotent = do+  let pairs =+        [ (ClassId leftKey, ClassId (leftKey + stride))+        | stride <- takeWhile (< 256) (iterate (* 2) 1),+          leftKey <- [0, 2 * stride .. 255 - stride]+        ]+      unionFind =+        foldl'+          (\current (leftClass, rightClass) -> UnionFind.union leftClass rightClass current)+          UnionFind.emptyUnionFind+          pairs+      (parents, compressed) =+        UnionFind.canonicalMapAndCompress unionFind+      (parentsAgain, compressedAgain) =+        UnionFind.canonicalMapAndCompress compressed+  assertEqual+    "second canonical map"+    parents+    parentsAgain+  assertBool+    "second compression is a semantic fixed point"+    (UnionFind.samePartition compressed compressedAgain)+  traverse_+    (\(key, rootClass) ->+       assertEqual+        ("compressed root for key " <> show key)+        (Just rootClass)+        (UnionFind.canonicalClass (ClassId key) compressed)+    )+    (IntMap.toAscList parents)++samePartitionIgnoresRepresentativeHistory :: Assertion+samePartitionIgnoresRepresentativeHistory = do+  let leftUnionFind =+        UnionFind.union (ClassId 0) (ClassId 10) $+          UnionFind.union (ClassId 10) (ClassId 11) UnionFind.emptyUnionFind+      rightUnionFind =+        UnionFind.union (ClassId 10) (ClassId 11) $+          UnionFind.union (ClassId 0) (ClassId 10) UnionFind.emptyUnionFind+  assertBool+    "representative histories differ"+    ( UnionFind.canonicalClass (ClassId 0) leftUnionFind+        /= UnionFind.canonicalClass (ClassId 0) rightUnionFind+    )+  assertBool+    "partitions agree"+    (UnionFind.samePartition leftUnionFind rightUnionFind)++abortedTransactionDoesNotCommit :: Assertion+abortedTransactionDoesNotCommit = do+  let base =+        UnionFind.fromClassIds+          [ClassId 0, ClassId 1]+      outcome =+        Transaction.runUnionFindTransactionEither base $ \editor -> do+          _ <- Transaction.transactionUnion editor (ClassId 0) (ClassId 1)+          pure (Left "abort" :: Either String ())+  case outcome of+    Left "abort" ->+      pure ()+    _ ->+      assertFailure ("transaction outcome changed: " <> show outcome)+  assertBool+    "base snapshot remains unchanged"+    (not (UnionFind.equivalent (ClassId 0) (ClassId 1) base))++unionInsertsAbsentClassIdentifiers :: Assertion+unionInsertsAbsentClassIdentifiers = do+  let leftClass = ClassId 4+      rightClass = ClassId 9+      unionFind = UnionFind.union leftClass rightClass UnionFind.emptyUnionFind+  assertEqual+    "absent union is total"+    ( True,+      True,+      True,+      Just leftClass,+      Just leftClass+    )+    ( UnionFind.member leftClass unionFind,+      UnionFind.member rightClass unionFind,+      UnionFind.equivalent leftClass rightClass unionFind,+      UnionFind.canonicalClass leftClass unionFind,+      UnionFind.canonicalClass rightClass unionFind+    )++makeSetPreservesUnionIntroducedRelationships :: Assertion+makeSetPreservesUnionIntroducedRelationships = do+  let unionFind = UnionFind.union (ClassId 2) (ClassId 3) UnionFind.emptyUnionFind+  (freshClass, grownUnionFind) <- expectRight (UnionFind.makeSet unionFind)+  assertEqual+    "high-water makeSet is above inserted ids"+    ( ClassId 4,+      True,+      Just (ClassId 2)+    )+    ( freshClass,+      UnionFind.equivalent (ClassId 2) (ClassId 3) grownUnionFind,+      IntMap.lookup 3 (UnionFind.canonicalMap grownUnionFind)+    )++persistentAllocationExhaustionPreservesPartition :: Assertion+persistentAllocationExhaustionPreservesPartition = do+  let unionFind = exhaustedUnionFind+      before = UnionFind.canonicalMap unionFind+  case UnionFind.makeSet unionFind of+    Left allocationError ->+      assertEqual "persistent allocation obstruction" ClassIdSpaceExhausted allocationError+    Right unexpectedAllocation ->+      assertFailure ("persistent exhaustion allocated: " <> show (fst unexpectedAllocation))+  assertEqual "persistent canonical map" before (UnionFind.canonicalMap unionFind)+  assertBool+    "persistent equivalence survives exhaustion"+    (UnionFind.equivalent (ClassId (maxBound - 1)) (ClassId maxBound) unionFind)++transactionalAllocationExhaustionPreservesPartition :: Assertion+transactionalAllocationExhaustionPreservesPartition = do+  let before = UnionFind.canonicalMap exhaustedUnionFind+      ((allocation, observedMap), committedUnionFind) =+        Transaction.runUnionFindTransaction exhaustedUnionFind $ \editor -> do+          editorAllocation <- Transaction.transactionMakeSet editor+          editorObservedMap <- Transaction.transactionCanonicalMapAndCompress editor+          pure (editorAllocation, editorObservedMap)+  assertEqual "transaction allocation obstruction" (Left ClassIdSpaceExhausted) allocation+  assertEqual "transaction canonical map" before observedMap+  assertEqual "committed canonical map" before (UnionFind.canonicalMap committedUnionFind)+  assertBool+    "transaction equivalence survives exhaustion"+    (UnionFind.equivalent (ClassId (maxBound - 1)) (ClassId maxBound) committedUnionFind)++ordinaryAllocationSequenceIsStable :: Assertion+ordinaryAllocationSequenceIsStable = do+  let negativeOnly = UnionFind.insertClassId (ClassId (-1)) UnionFind.emptyUnionFind+  (class0, unionFind1) <- expectRight (UnionFind.makeSet negativeOnly)+  (class1, unionFind2) <- expectRight (UnionFind.makeSet unionFind1)+  (class2, _unionFind3) <- expectRight (UnionFind.makeSet unionFind2)+  assertEqual "ordinary allocation sequence" [ClassId 0, ClassId 1, ClassId 2] [class0, class1, class2]++exhaustedUnionFind :: UnionFind+exhaustedUnionFind =+  UnionFind.union+    (ClassId (maxBound - 1))+    (ClassId maxBound)+    UnionFind.emptyUnionFind++expectRight :: Show errorValue => Either errorValue value -> IO value+expectRight result =+  case result of+    Left failure ->+      assertFailure ("unexpected Left: " <> show failure)+    Right value ->+      pure value
+ test/support/LawProperty.hs view
@@ -0,0 +1,12 @@+module LawProperty+  ( lawProperty,+  )+where++import Moonlight.Core (IsLawName (..))+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (Testable, testProperty)++lawProperty :: (IsLawName law, Testable property) => law -> property -> TestTree+lawProperty lawName =+  testProperty (lawNameText lawName)
+ test/support/SourceShape.hs view
@@ -0,0 +1,116 @@+module SourceShape+  ( assertSourceShape,+    assertTopLevelDeclarationExcludesToken,+  )+where++import Data.Char (isAlphaNum, isSpace)+import Data.Foldable (traverse_)+import Data.List (isInfixOf, isPrefixOf)+import System.FilePath ((</>), joinPath, normalise, splitDirectories)+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure)++assertSourceShape :: FilePath -> FilePath -> [String] -> [String] -> Assertion+assertSourceShape testModulePath relativeSourcePath requiredFragments forbiddenFragments =+  case sourcePathFromTestModule testModulePath relativeSourcePath of+    Left pathFailure ->+      assertFailure pathFailure+    Right sourcePath ->+      readFile sourcePath+        >>= assertSourceTextFragments requiredFragments forbiddenFragments++assertTopLevelDeclarationExcludesToken :: FilePath -> FilePath -> String -> String -> Assertion+assertTopLevelDeclarationExcludesToken testModulePath relativeSourcePath declarationPrefix forbiddenToken = do+  case sourcePathFromTestModule testModulePath relativeSourcePath of+    Left pathFailure ->+      assertFailure pathFailure+    Right sourcePath -> do+      sourceText <- readFile sourcePath+      case topLevelDeclarationBlock declarationPrefix sourceText of+        Left parseFailure ->+          assertFailure parseFailure+        Right declarationBlock ->+          assertBool+            ( "expected "+                <> declarationPrefix+                <> " declaration in "+                <> relativeSourcePath+                <> " to exclude token: "+                <> forbiddenToken+                <> "\n\nDeclaration:\n"+                <> declarationBlock+            )+            (not (forbiddenToken `elem` sourceTokens declarationBlock))++topLevelDeclarationBlock :: String -> String -> Either String String+topLevelDeclarationBlock declarationPrefix sourceText =+  case dropWhile (not . isTargetDeclaration) (lines sourceText) of+    [] ->+      Left ("expected to find top-level declaration: " <> declarationPrefix)+    declarationLine : remainingLines ->+      Right (unlines (declarationLine : takeWhile isDeclarationContinuation remainingLines))+  where+    isTargetDeclaration sourceLine =+      declarationPrefix `isPrefixOf` trimLeft sourceLine++isDeclarationContinuation :: String -> Bool+isDeclarationContinuation sourceLine =+  null sourceLine || startsWithSpace sourceLine++sourceTokens :: String -> [String]+sourceTokens =+  words . fmap tokenCharacter+  where+    tokenCharacter character+      | isAlphaNum character || character == '_' || character == '\'' = character+      | otherwise = ' '++startsWithSpace :: String -> Bool+startsWithSpace sourceLine =+  case sourceLine of+    leadingCharacter : _ -> isSpace leadingCharacter+    [] -> False++trimLeft :: String -> String+trimLeft =+  dropWhile isSpace++sourcePathFromTestModule :: FilePath -> FilePath -> Either String FilePath+sourcePathFromTestModule testModulePath relativeSourcePath =+  (</> relativeSourcePath) <$> packageRootFromTestModule testModulePath++packageRootFromTestModule :: FilePath -> Either String FilePath+packageRootFromTestModule testModulePath =+  case span (/= packageDirectoryName) (reverse pathDirectories) of+    (_afterPackageRoot, packageDirectory : reversedPrefix)+      | packageDirectory == packageDirectoryName ->+          Right (joinPath (reverse (packageDirectory : reversedPrefix)))+    _ ->+      case pathDirectories of+        testDirectory : _remainingPath+          | testDirectory == "test" ->+              Right "."+        _ ->+          Left ("expected test module path to contain " <> packageDirectoryName <> " package root: " <> testModulePath)+  where+    pathDirectories =+      splitDirectories (normalise testModulePath)++packageDirectoryName :: FilePath+packageDirectoryName =+  "moonlight-core"++assertSourceTextFragments :: [String] -> [String] -> String -> Assertion+assertSourceTextFragments requiredFragments forbiddenFragments sourceText =+  do+    traverse_ assertRequiredFragment requiredFragments+    traverse_ assertForbiddenFragment forbiddenFragments+  where+    assertRequiredFragment fragment =+      assertBool+        ("expected source shape to contain: " <> fragment)+        (fragment `isInfixOf` sourceText)+    assertForbiddenFragment fragment =+      assertBool+        ("expected source shape to exclude: " <> fragment)+        (not (fragment `isInfixOf` sourceText))
+ test/syntax/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import qualified SyntaxTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain SyntaxTests.tests
+ test/syntax/PatternSpec.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE DerivingStrategies #-}++module PatternSpec (tests) where++import Data.Kind (Type)+import Data.Foldable (toList)+import Data.List (sort)+import Moonlight.Core (Pattern (..), patternVariables)+import Moonlight.Core qualified as EGraph+import Moonlight.Core (IsLawName (..), constructorLawName)+import LawProperty (lawProperty)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)+import Test.Tasty.QuickCheck (Arbitrary (arbitrary), Gen, frequency, listOf, resize, sized)++data PatternLaw+  = PatternCataAfterAnaIdentity+  | PatternInterpreterCoherence+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance IsLawName PatternLaw where+  lawNameText =+    constructorLawName . show++cataAfterAnaIdentity :: Eq seed => (seed -> recursive) -> (recursive -> seed) -> seed -> Bool+cataAfterAnaIdentity anamorphism catamorphism seed = catamorphism (anamorphism seed) == seed++interpreterCoherence :: Eq value => (seed -> recursive) -> (recursive -> value) -> (seed -> value) -> seed -> Bool+interpreterCoherence anamorphism interpretation seedInterpreter seed = seedInterpreter seed == interpretation (anamorphism seed)++type PatternSeed :: Type+data PatternSeed+  = PatternSeedVar EGraph.PatternVar+  | PatternSeedNode [PatternSeed]+  deriving stock (Eq, Show)++patternFromSeed :: PatternSeed -> Pattern []+patternFromSeed seed =+  case seed of+    PatternSeedVar patternVar ->+      PatternVar patternVar+    PatternSeedNode children ->+      PatternNode (map patternFromSeed children)++patternSeedFromPattern :: Pattern [] -> PatternSeed+patternSeedFromPattern patternValue =+  case patternValue of+    PatternVar patternVar ->+      PatternSeedVar patternVar+    PatternNode children ->+      PatternSeedNode (map patternSeedFromPattern children)++canonicalPatternVars :: [EGraph.PatternVar] -> [EGraph.PatternVar]+canonicalPatternVars =+  foldr+    ( \patternVar accumulatedPatternVars ->+        case accumulatedPatternVars of+          [] ->+            [patternVar]+          accumulatedHead : _ ->+            if patternVar == accumulatedHead+              then accumulatedPatternVars+              else patternVar : accumulatedPatternVars+    )+    []+    . sort++patternSeedVariables :: PatternSeed -> [EGraph.PatternVar]+patternSeedVariables seed =+  case seed of+    PatternSeedVar patternVar ->+      [patternVar]+    PatternSeedNode children ->+      canonicalPatternVars (foldMap patternSeedVariables children)++patternVariablesCanonical :: Pattern [] -> [EGraph.PatternVar]+patternVariablesCanonical =+  toList . patternVariables++samplePatternSeeds :: [PatternSeed]+samplePatternSeeds =+  [ PatternSeedVar (EGraph.mkPatternVar 1),+    PatternSeedNode [],+    PatternSeedNode [PatternSeedVar (EGraph.mkPatternVar 2), PatternSeedVar (EGraph.mkPatternVar 3)],+    PatternSeedNode+      [ PatternSeedVar (EGraph.mkPatternVar 4),+        PatternSeedNode [PatternSeedVar (EGraph.mkPatternVar 4), PatternSeedVar (EGraph.mkPatternVar 5)]+      ]+  ]++patternSeedAtomGen :: Gen PatternSeed+patternSeedAtomGen =+  PatternSeedVar . EGraph.mkPatternVar <$> arbitrary++patternSeedGenSized :: Int -> Gen PatternSeed+patternSeedGenSized size =+  case size of+    0 ->+      patternSeedAtomGen+    _ ->+      frequency+        [ (2, patternSeedAtomGen),+          (1, PatternSeedNode <$> childSeedListGen)+        ]+  where+    childSeedSize = size `div` 2+    childSeedListGen =+      resize childSeedSize (listOf (patternSeedGenSized childSeedSize))++instance Arbitrary PatternSeed where+  arbitrary =+    sized patternSeedGenSized++tests :: TestTree+tests =+  testGroup+    "Pattern"+    [ testCase "patternVariables collects variables from sample recursive patterns" $+        patternVariablesCanonical+          ( patternFromSeed+              ( PatternSeedNode+                  [ PatternSeedVar (EGraph.mkPatternVar 1),+                    PatternSeedNode [PatternSeedVar (EGraph.mkPatternVar 2), PatternSeedVar (EGraph.mkPatternVar 1)]+                  ]+              )+          )+          @?= [EGraph.mkPatternVar 1, EGraph.mkPatternVar 2],+      testCase "pattern ordering follows constructor declaration order" $+        compare (PatternVar (EGraph.mkPatternVar 0) :: Pattern []) (PatternNode [])+          @?= LT,+      testCase "pattern seed reconstruction holds across sample recursive patterns" $+        map (cataAfterAnaIdentity patternFromSeed patternSeedFromPattern) samplePatternSeeds+          @?= [True, True, True, True],+      testCase "pattern variable interpretation is coherent across sample recursive patterns" $+        map+          (interpreterCoherence patternFromSeed patternVariablesCanonical patternSeedVariables)+          samplePatternSeeds+          @?= [True, True, True, True],+      lawProperty PatternCataAfterAnaIdentity $+        cataAfterAnaIdentity patternFromSeed patternSeedFromPattern,+      lawProperty PatternInterpreterCoherence $+        interpreterCoherence patternFromSeed patternVariablesCanonical patternSeedVariables+    ]
+ test/syntax/SubstitutionSpec.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE DerivingStrategies #-}++module SubstitutionSpec (tests) where++import Control.Monad (foldM)+import Data.IntMap.Strict qualified as IntMap+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Maybe (isJust, mapMaybe)+import Moonlight.Core (ClassId (..), PatternVar, mkPatternVar)+import Moonlight.Core (IsLawName (..), constructorLawName)+import Moonlight.Core+  ( Substitution (..),+    extendSubst,+    intersectRootedMatches,+    insertSubst,+    lookupSubst,+    mergeSubstitutions,+  )+import LawProperty (lawProperty)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)+import Test.Tasty.QuickCheck+  ( Arbitrary (..),+    Gen,+    Property,+    chooseInt,+    counterexample,+    listOf,+    property,+    resize,+    vectorOf,+    (===),+    (.&&.),+  )++data SubstitutionLaw+  = SubstitutionExtendAgreement+  | SubstitutionMergeIdempotent+  | SubstitutionMergeCommutative+  | SubstitutionMergeAssociative+  | SubstitutionMergeAgreement+  | SubstitutionRootedMatchIntersectionFiberProduct+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance IsLawName SubstitutionLaw where+  lawNameText =+    constructorLawName . show++newtype SmallPatternVar = SmallPatternVar PatternVar+  deriving stock (Eq, Ord, Show)++newtype SmallClassId = SmallClassId ClassId+  deriving stock (Eq, Ord, Show)++newtype SmallSubstitution = SmallSubstitution Substitution+  deriving stock (Eq, Ord, Show)++newtype RootedMatchSets = RootedMatchSets (NonEmpty [(ClassId, Substitution)])+  deriving stock (Eq, Show)++instance Arbitrary SmallPatternVar where+  arbitrary =+    SmallPatternVar <$> genPatternVar++instance Arbitrary SmallClassId where+  arbitrary =+    SmallClassId <$> genClassId++instance Arbitrary SmallSubstitution where+  arbitrary =+    SmallSubstitution <$> genSubstitution++instance Arbitrary RootedMatchSets where+  arbitrary =+    RootedMatchSets <$> genRootedMatchSets++tests :: TestTree+tests =+  testGroup+    "Substitution"+    [ lawProperty SubstitutionExtendAgreement propExtendAgreement,+      lawProperty SubstitutionMergeIdempotent propMergeIdempotent,+      lawProperty SubstitutionMergeCommutative propMergeCommutative,+      lawProperty SubstitutionMergeAssociative propMergeAssociative,+      lawProperty SubstitutionMergeAgreement propMergeAgreement,+      lawProperty SubstitutionRootedMatchIntersectionFiberProduct propRootedMatchIntersectionFiberProduct,+      testCase "rooted match intersection preserves left-major multiplicity inside class fibers" testRootedMatchIntersectionFiberOrder+    ]++propExtendAgreement :: SmallPatternVar -> SmallClassId -> SmallSubstitution -> Property+propExtendAgreement (SmallPatternVar patternVar) (SmallClassId classId) (SmallSubstitution substitution) =+  counterexample "extension success does not match agreement with the existing binding" (isJust extended === agrees)+    .&&. counterexample "successful extension does not contain the requested binding" (property resultContainsBinding)+  where+    extended =+      extendSubst patternVar classId substitution+    agrees =+      maybe True (== classId) (lookupSubst patternVar substitution)+    resultContainsBinding =+      maybe True ((== Just classId) . lookupSubst patternVar) extended++propMergeIdempotent :: SmallSubstitution -> Property+propMergeIdempotent (SmallSubstitution substitution) =+  mergeSubstitutions substitution substitution === Just substitution++propMergeCommutative :: SmallSubstitution -> SmallSubstitution -> Property+propMergeCommutative (SmallSubstitution left) (SmallSubstitution right) =+  mergeSubstitutions left right === mergeSubstitutions right left++propMergeAssociative :: SmallSubstitution -> SmallSubstitution -> SmallSubstitution -> Property+propMergeAssociative (SmallSubstitution left) (SmallSubstitution middle) (SmallSubstitution right) =+  mergeLeftFirst === mergeRightFirst+  where+    mergeLeftFirst =+      mergeSubstitutions left middle >>= \mergedLeft ->+        mergeSubstitutions mergedLeft right+    mergeRightFirst =+      mergeSubstitutions middle right >>= \mergedRight ->+        mergeSubstitutions left mergedRight++propMergeAgreement :: SmallSubstitution -> SmallSubstitution -> Property+propMergeAgreement (SmallSubstitution left) (SmallSubstitution right) =+  mergeSubstitutions left right === expectedMerge left right++propRootedMatchIntersectionFiberProduct :: RootedMatchSets -> Property+propRootedMatchIntersectionFiberProduct (RootedMatchSets rootedMatches) =+  intersectRootedMatches rootedMatches === expectedIntersectRootedMatches rootedMatches++testRootedMatchIntersectionFiberOrder :: IO ()+testRootedMatchIntersectionFiberOrder =+  intersectRootedMatches (leftMatches :| [rightMatches])+    @?= [ (ClassId 1, insertSubst (mkPatternVar 1) (ClassId 10) emptyLeft),+          (ClassId 1, insertSubst (mkPatternVar 2) (ClassId 20) emptyLeft),+          (ClassId 2, insertSubst (mkPatternVar 3) (ClassId 30) emptyLeft),+          (ClassId 1, insertSubst (mkPatternVar 1) (ClassId 10) emptyLeft),+          (ClassId 1, insertSubst (mkPatternVar 2) (ClassId 20) emptyLeft)+        ]+  where+    emptyLeft =+      Substitution IntMap.empty+    leftMatches =+      [(ClassId 1, emptyLeft), (ClassId 2, emptyLeft), (ClassId 1, emptyLeft)]+    rightMatches =+      [ (ClassId 1, insertSubst (mkPatternVar 1) (ClassId 10) emptyLeft),+        (ClassId 2, insertSubst (mkPatternVar 3) (ClassId 30) emptyLeft),+        (ClassId 1, insertSubst (mkPatternVar 2) (ClassId 20) emptyLeft)+      ]++expectedMerge :: Substitution -> Substitution -> Maybe Substitution+expectedMerge left right =+  if substitutionsAgree left right+    then Just (unionSubstitutions left right)+    else Nothing++substitutionsAgree :: Substitution -> Substitution -> Bool+substitutionsAgree (Substitution left) (Substitution right) =+  and (IntMap.intersectionWith (==) left right)++unionSubstitutions :: Substitution -> Substitution -> Substitution+unionSubstitutions (Substitution left) (Substitution right) =+  Substitution (IntMap.union left right)++expectedIntersectRootedMatches :: NonEmpty [(ClassId, Substitution)] -> [(ClassId, Substitution)]+expectedIntersectRootedMatches rootedMatches =+  mapMaybe rootedCombination (sequenceA (NonEmpty.toList rootedMatches))++rootedCombination :: [(ClassId, Substitution)] -> Maybe (ClassId, Substitution)+rootedCombination matches =+  case matches of+    [] ->+      Nothing+    (rootClassId, rootSubstitution) : remainingMatches+      | all ((== rootClassId) . fst) remainingMatches ->+          fmap+            (\mergedSubstitution -> (rootClassId, mergedSubstitution))+            (foldM mergeSubstitutions rootSubstitution (snd <$> remainingMatches))+      | otherwise ->+          Nothing++genPatternVar :: Gen PatternVar+genPatternVar =+  mkPatternVar <$> chooseInt (0, 5)++genClassId :: Gen ClassId+genClassId =+  ClassId <$> chooseInt (0, 5)++genSubstitution :: Gen Substitution+genSubstitution =+  Substitution . IntMap.fromList <$> resize 6 (listOf genEntry)++genEntry :: Gen (Int, ClassId)+genEntry =+  (,) <$> chooseInt (0, 5) <*> genClassId++genRootedMatchSets :: Gen (NonEmpty [(ClassId, Substitution)])+genRootedMatchSets =+  (:|)+    <$> genRootedMatchList+    <*> (chooseInt (0, 3) >>= \count -> vectorOf count genRootedMatchList)++genRootedMatchList :: Gen [(ClassId, Substitution)]+genRootedMatchList =+  chooseInt (0, 4) >>= \count ->+    vectorOf count genRootedMatch++genRootedMatch :: Gen (ClassId, Substitution)+genRootedMatch =+  (,) <$> genClassId <*> genSubstitution
+ test/syntax/SyntaxTests.hs view
@@ -0,0 +1,18 @@+module SyntaxTests+  ( tests,+  )+where++import qualified PatternSpec as PatternSpec+import qualified SubstitutionSpec as SubstitutionSpec+import qualified TheorySpec as TheorySpec+import Test.Tasty (TestTree, testGroup)++tests :: TestTree+tests =+  testGroup+    "moonlight-core-syntax"+    [ PatternSpec.tests,+      SubstitutionSpec.tests,+      TheorySpec.tests+    ]
+ test/syntax/TheorySpec.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}++module TheorySpec (tests) where++import Data.Set qualified as Set+import Moonlight.Core qualified as EGraph+import Moonlight.Core (IsLawName (..), constructorLawName)+import Moonlight.Core (Pattern (..))+import LawProperty (lawProperty)+import Moonlight.Core+  ( StructuralLaw (..),+    TheorySpec (..),+    canonicalizeLayerByTheory,+    canonicalizePatternByTheory,+    commutativeBinary,+    expandPatternByTheory,+  )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)+import Test.Tasty.QuickCheck+  ( Arbitrary (..),+    Gen,+    Property,+    chooseInt,+    counterexample,+    frequency,+    oneof,+    property,+    sized,+    (===),+  )++data TheoryLaw+  = TheoryCanonicalizationIdempotent+  | TheoryCanonicalChoiceDeterministicByTermOrder+  | TheoryExpansionExactCommutativeOrbit+  | TheoryExpansionDuplicateFree+  | TheoryExpansionContainsCanonicalForm+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance IsLawName TheoryLaw where+  lawNameText =+    constructorLawName . show++data TheoryNode a+  = TheoryLeaf !Int+  | TheoryUnary !a+  | TheoryAdd !a !a+  | TheoryPair !a !a+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)++newtype SmallTheoryNode = SmallTheoryNode (TheoryNode Int)+  deriving stock (Eq, Ord, Show)++newtype SmallTheoryPattern = SmallTheoryPattern (Pattern TheoryNode)+  deriving stock (Eq, Ord, Show)++instance Arbitrary SmallTheoryNode where+  arbitrary =+    SmallTheoryNode <$> genTheoryNode genChild++instance Arbitrary SmallTheoryPattern where+  arbitrary =+    SmallTheoryPattern <$> sized (genPattern . min 5)++tests :: TestTree+tests =+  testGroup+    "Theory"+    [ lawProperty TheoryCanonicalizationIdempotent propCanonicalizationIdempotent,+      lawProperty TheoryCanonicalChoiceDeterministicByTermOrder propCanonicalChoiceDeterministicByTermOrder,+      lawProperty TheoryExpansionExactCommutativeOrbit propExpansionExactCommutativeOrbit,+      lawProperty TheoryExpansionDuplicateFree propExpansionDuplicateFree,+      lawProperty TheoryExpansionContainsCanonicalForm propExpansionContainsCanonicalForm,+      testCase "recursive canonicalization orients pattern variables before pattern nodes" testRecursiveCanonicalizationDeclarationOrder+    ]++propCanonicalizationIdempotent :: SmallTheoryNode -> Property+propCanonicalizationIdempotent (SmallTheoryNode node) =+  canonicalizeLayerByTheory commutativeTheory (canonicalizeLayerByTheory commutativeTheory node)+    === canonicalizeLayerByTheory commutativeTheory node++propCanonicalChoiceDeterministicByTermOrder :: SmallTheoryNode -> Property+propCanonicalChoiceDeterministicByTermOrder (SmallTheoryNode node) =+  canonicalizeLayerByTheory commutativeTheory node === expectedCanonicalNode node++propExpansionExactCommutativeOrbit :: SmallTheoryPattern -> Property+propExpansionExactCommutativeOrbit (SmallTheoryPattern patternValue) =+  Set.fromList (expandPatternByTheory commutativeTheory patternValue) === commutativeOrbit patternValue++propExpansionDuplicateFree :: SmallTheoryPattern -> Property+propExpansionDuplicateFree (SmallTheoryPattern patternValue) =+  Set.size expandedSet === length expandedPatterns+  where+    expandedPatterns =+      expandPatternByTheory commutativeTheory patternValue+    expandedSet =+      Set.fromList expandedPatterns++propExpansionContainsCanonicalForm :: SmallTheoryPattern -> Property+propExpansionContainsCanonicalForm (SmallTheoryPattern patternValue) =+  counterexample "expanded orbit does not contain the recursive canonical form" $+    property (Set.member (canonicalizePatternByTheory commutativeTheory patternValue) (Set.fromList (expandPatternByTheory commutativeTheory patternValue)))++testRecursiveCanonicalizationDeclarationOrder :: IO ()+testRecursiveCanonicalizationDeclarationOrder =+  canonicalizePatternByTheory commutativeTheory unorderedPattern+    @?= orderedPattern+  where+    unorderedPattern =+      PatternNode+        ( TheoryAdd+            (PatternNode (TheoryLeaf 1))+            (PatternVar (EGraph.mkPatternVar 0))+        )+    orderedPattern =+      PatternNode+        ( TheoryAdd+            (PatternVar (EGraph.mkPatternVar 0))+            (PatternNode (TheoryLeaf 1))+        )++commutativeTheory :: TheorySpec TheoryNode+commutativeTheory =+  TheorySpec+    { tsClassify = \node ->+        case node of+          TheoryAdd _left _right ->+            commutativeBinary TheoryAdd+          _ ->+            Ordinary+    }++expectedCanonicalNode :: Ord a => TheoryNode a -> TheoryNode a+expectedCanonicalNode node =+  case node of+    TheoryAdd left right ->+      TheoryAdd (min left right) (max left right)+    _ ->+      node++commutativeOrbit :: Pattern TheoryNode -> Set.Set (Pattern TheoryNode)+commutativeOrbit patternValue =+  case patternValue of+    PatternVar patternVar ->+      Set.singleton (PatternVar patternVar)+    PatternNode node ->+      Set.fromList (PatternNode <$> (expandedChildNodes >>= localNodeOrbit))+      where+        expandedChildNodes =+          traverse (Set.toList . commutativeOrbit) node++localNodeOrbit :: TheoryNode (Pattern TheoryNode) -> [TheoryNode (Pattern TheoryNode)]+localNodeOrbit node =+  case node of+    TheoryAdd left right+      | left == right ->+          [node]+      | otherwise ->+          [node, TheoryAdd right left]+    _ ->+      [node]++genChild :: Gen Int+genChild =+  chooseInt (0, 5)++genPatternVar :: Gen EGraph.PatternVar+genPatternVar =+  EGraph.mkPatternVar <$> chooseInt (0, 5)++genTheoryNode :: Gen a -> Gen (TheoryNode a)+genTheoryNode genValue =+  frequency+    [ (1, TheoryLeaf <$> chooseInt (0, 3)),+      (2, TheoryUnary <$> genValue),+      (3, TheoryAdd <$> genValue <*> genValue),+      (2, TheoryPair <$> genValue <*> genValue)+    ]++genPattern :: Int -> Gen (Pattern TheoryNode)+genPattern size =+  case compare size 0 of+    GT ->+      frequency+        [ (2, PatternVar <$> genPatternVar),+          (2, PatternNode . TheoryLeaf <$> chooseInt (0, 3)),+          (2, PatternNode . TheoryUnary <$> genSmallerPattern),+          (3, PatternNode <$> (TheoryAdd <$> genSmallerPattern <*> genSmallerPattern)),+          (2, PatternNode <$> (TheoryPair <$> genSmallerPattern <*> genSmallerPattern))+        ]+    _ ->+      oneof+        [ PatternVar <$> genPatternVar,+          PatternNode . TheoryLeaf <$> chooseInt (0, 3)+        ]+  where+    genSmallerPattern =+      genPattern (size `div` 2)
+ test/term/DatabaseLawSpec.hs view
@@ -0,0 +1,861 @@+{-# LANGUAGE DeriveTraversable #-}++module DatabaseLawSpec+  ( tests,+  )+where++import Control.Monad (foldM)+import Data.Foldable (toList)+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.List (sort)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Set (Set)+import Data.Set qualified as Set+import Moonlight.Core+  ( IsLawName (..),+    constructorLawName,+  )+import Moonlight.Core+  ( ArrangementValidationError,+    Database,+    DatabaseRow,+    DatabaseRowDelta (..),+    FreeJoinPlan (..),+    Operator,+    QueryAtom (..),+    QueryBinding (..),+    QueryTerm (..),+    QueryVar (..),+    TermCommitResult (..),+    TermCommand (..),+    TupleLookup (..),+    commitTermCommands,+    compact,+    databaseEntries,+    entriesForResultKey,+    operatorRows,+    rowChildren,+    rowEntry,+    rowResult,+    rowsForOperator,+    deleteTuple,+    emptyDatabase,+    extractOperator,+    insertTuple,+    insertTuples,+    lookupTupleAll,+    rehydrateTuple,+  )+import Moonlight.Core qualified as Database+import Moonlight.Core+  ( canonicalizeDatabase,+    canonicalizeDirtyRows,+  )+import Prelude+import Test.Tasty (TestTree, localOption, testGroup)+import Test.QuickCheck (Testable)+import Test.Tasty.QuickCheck qualified as QuickCheck++data TestTerm key+  = TNull+  | TUnary !key+  | TBinary !key !key+  | TNary [key]+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)++data TermDatabaseLawName+  = TermDatabaseRoundTrip+  | TermDatabaseInsertIdempotenceUnionClosure+  | TermDatabaseCommitInsertFrontier+  | TermDatabaseBulkEqualsRepeated+  | TermDatabaseCompactionFixpoint+  | TermDatabaseCanonicalizationMorphism+  | TermDatabaseFreeJoinNaiveEnumeration+  | TermDatabaseWatermarkDeferredIndexInterleaving+  deriving stock (Bounded, Enum, Eq, Ord, Show)++instance IsLawName TermDatabaseLawName where+  lawNameText =+    constructorLawName . show++tests :: TestTree+tests =+  localOption (QuickCheck.QuickCheckTests 80) $+    testGroup+      "Moonlight.Core.Term.Database laws"+      [ lawProperty TermDatabaseRoundTrip propRoundTrip,+        lawProperty TermDatabaseInsertIdempotenceUnionClosure propInsertIdempotenceUnionClosure,+        lawProperty TermDatabaseCommitInsertFrontier propCommitInsertFrontier,+        lawProperty TermDatabaseBulkEqualsRepeated propBulkEqualsRepeated,+        lawProperty TermDatabaseCompactionFixpoint propCompactionFixpoint,+        lawProperty TermDatabaseCanonicalizationMorphism propCanonicalizationMorphism,+        lawProperty TermDatabaseFreeJoinNaiveEnumeration propFreeJoinNaiveEnumeration,+        lawProperty TermDatabaseWatermarkDeferredIndexInterleaving propWatermarkDeferredIndexInterleaving+      ]++lawProperty :: Testable property => TermDatabaseLawName -> property -> TestTree+lawProperty lawName =+  QuickCheck.testProperty (lawNameText lawName)++newtype RoundTripCase = RoundTripCase (Int, TestTerm Int)+  deriving stock (Eq, Show)++data CommitClosureCase = CommitClosureCase [(Int, TestTerm Int)] [(Int, TestTerm Int)]+  deriving stock (Eq, Show)++data BulkInsertCase = BulkInsertCase [(Int, TestTerm Int)] [(Int, TestTerm Int)]+  deriving stock (Eq, Show)++data CompactionCase = CompactionCase [(Int, TestTerm Int)] [(Int, TestTerm Int)]+  deriving stock (Eq, Show)++data KeyCanonicalizer = KeyCanonicalizer !Int+  deriving stock (Eq, Show)++data CanonicalizationCase = CanonicalizationCase [(Int, TestTerm Int)] !IntSet !KeyCanonicalizer+  deriving stock (Eq, Show)++data FreeJoinCase = FreeJoinCase [(Int, TestTerm Int)] (FreeJoinPlan TestTerm Int)++instance Show FreeJoinCase where+  show (FreeJoinCase entries plan) =+    "FreeJoinCase " <> show entries <> " " <> showFreeJoinPlan plan++newtype WatermarkInterleavingCase = WatermarkInterleavingCase [TermDatabaseAction]+  deriving stock (Eq, Show)++data TermDatabaseAction+  = InsertSingle !(Int, TestTerm Int)+  | InsertBatch ![(Int, TestTerm Int)]+  | DeleteExact !(Int, TestTerm Int)+  | CompactDatabase+  | QueryEntriesForResultKey !Int+  | QueryTupleAll !(TestTerm Int)+  | QueryFixedFreeJoin+  deriving stock (Eq, Show)++newtype ReferenceTermTable = ReferenceTermTable (Map (TestTerm Int) (Set Int))++data InterleavingState = InterleavingState+  { interleavingDatabase :: !(Database TestTerm Int),+    interleavingReference :: !ReferenceTermTable+  }++data InterleavingMismatch+  = FinalEntriesMismatch !(Set (Int, TestTerm Int)) !(Set (Int, TestTerm Int))+  | ResultEntriesMismatch !Int !(Set (Int, TestTerm Int)) !(Set (Int, TestTerm Int))+  | TupleOwnersMismatch !(TestTerm Int) !(Set Int) !(Set Int)+  | FixedFreeJoinValidationFailure !ArrangementValidationError+  | FixedFreeJoinBindingsMismatch !(Set (Map QueryVar Int)) !(Set (Map QueryVar Int))+  deriving stock (Show)++instance QuickCheck.Arbitrary RoundTripCase where+  arbitrary =+    RoundTripCase <$> entryGen++instance QuickCheck.Arbitrary CommitClosureCase where+  arbitrary =+    CommitClosureCase <$> entryListGen 14 <*> entryListGen 14++instance QuickCheck.Arbitrary BulkInsertCase where+  arbitrary =+    BulkInsertCase <$> entryListGen 18 <*> entryListGen 18++instance QuickCheck.Arbitrary CompactionCase where+  arbitrary =+    CompactionCase <$> entryListGen 18 <*> entryListGen 10++instance QuickCheck.Arbitrary KeyCanonicalizer where+  arbitrary =+    KeyCanonicalizer <$> QuickCheck.chooseInt (1, 8)++instance QuickCheck.Arbitrary CanonicalizationCase where+  arbitrary = do+    entries <- entryListGen 18+    canonicalizer <- QuickCheck.arbitrary+    dirtyKeys <- dirtyKeySetGen entries+    pure (CanonicalizationCase entries dirtyKeys canonicalizer)++instance QuickCheck.Arbitrary FreeJoinCase where+  arbitrary =+    FreeJoinCase <$> entryListGen 12 <*> freeJoinPlanGen++instance QuickCheck.Arbitrary WatermarkInterleavingCase where+  arbitrary = do+    sharedEntry <- interleavingEntryGen+    batchEntries <- interleavingEntryListGen 5+    resultProbe <- interleavingKeyGen+    tupleProbe <- interleavingTermGen+    additionalActionCount <- QuickCheck.chooseInt (10, 22)+    additionalActions <- QuickCheck.vectorOf additionalActionCount interleavingActionGen+    WatermarkInterleavingCase+      <$> QuickCheck.shuffle+        ( [ InsertSingle sharedEntry,+            InsertBatch batchEntries,+            DeleteExact sharedEntry,+            CompactDatabase,+            QueryEntriesForResultKey resultProbe,+            QueryTupleAll tupleProbe,+            QueryFixedFreeJoin+          ]+            <> additionalActions+        )++propRoundTrip :: RoundTripCase -> QuickCheck.Property+propRoundTrip (RoundTripCase (resultKey, term)) =+  case rowsForOperator operator db of+    [(_rowId, row)] ->+      QuickCheck.conjoin+        [ rowEntry operator row QuickCheck.=== Just (resultKey, term),+          rehydrateTuple operator (rowResult row : rowChildren row) QuickCheck.=== Just (resultKey, term)+        ]+    rows ->+      QuickCheck.counterexample ("expected one encoded row, got " <> show rows) False+  where+    operator =+      extractOperator term+    db =+      insertTuple resultKey term (emptyDatabase :: Database TestTerm Int)++propInsertIdempotenceUnionClosure :: CommitClosureCase -> QuickCheck.Property+propInsertIdempotenceUnionClosure (CommitClosureCase baseEntries insertedEntries) =+  QuickCheck.counterexample counterexampleText $+    QuickCheck.conjoin+      [ entrySet committedDb QuickCheck.=== expectedCommittedEntries,+        unionResultSet residualCommandList QuickCheck.=== expectedResidualPairs,+        entrySet duplicateCommittedDb QuickCheck.=== entrySet committedDb+      ]+  where+    baseDb =+      databaseFromEntries baseEntries+    commands =+      fmap (uncurry InsertTerm) insertedEntries+    duplicateCommands =+      commands <> commands+    commitResult =+      commitTermCommands commands baseDb+    duplicateCommitResult =+      commitTermCommands duplicateCommands baseDb+    residualCommandList =+      residualCommands commitResult+    committedDb =+      committedDatabase commitResult+    duplicateCommittedDb =+      committedDatabase duplicateCommitResult+    expectedCommittedEntries =+      Set.union (entrySet baseDb) (Set.fromList insertedEntries)+    expectedResidualPairs =+      expectedInsertClosurePairs baseDb insertedEntries+    counterexampleText =+      "base: "+        <> show (entryList baseDb)+        <> "\ninserted: "+        <> show insertedEntries+        <> "\nresidual: "+        <> show (termCommandsText residualCommandList)+        <> "\nexpected residual pairs: "+        <> show expectedResidualPairs++propCommitInsertFrontier :: CommitClosureCase -> QuickCheck.Property+propCommitInsertFrontier (CommitClosureCase baseEntries candidateEntries) =+  QuickCheck.counterexample counterexampleText $+    QuickCheck.conjoin+      [ QuickCheck.counterexample "frontier row ids must be unique and ascending per operator" $+          QuickCheck.property (all frontierIdsUniqueAndAscending frontierByOperator),+        QuickCheck.counterexample "every frontier row must occur at the same id in the committed snapshot" $+          QuickCheck.property (all (frontierRowsPresent committedRowsByOperator) (Map.toAscList frontierByOperator)),+        QuickCheck.counterexample "frontier rows must all rehydrate" $+          QuickCheck.property (maybe False (const True) frontierEntries),+        frontierEntries QuickCheck.=== Just semanticEntryIncrease+      ]+  where+    baseDatabase =+      databaseFromEntries baseEntries+    commitResult =+      commitTermCommands (fmap (uncurry InsertTerm) candidateEntries) baseDatabase+    committedSnapshot =+      committedDatabase commitResult+    frontierByOperator =+      insertedRows commitResult+    committedRowsByOperator =+      operatorRows committedSnapshot+    frontierEntries =+      fmap (Set.fromList . concat) $+        traverse+          (\(operator, rows) -> traverse (rowEntry operator . snd) rows)+          (Map.toAscList frontierByOperator)+    semanticEntryIncrease =+      Set.difference (entrySet committedSnapshot) (entrySet baseDatabase)+    counterexampleText =+      "base entries: "+        <> show (entryList baseDatabase)+        <> "\ncandidate entries: "+        <> show candidateEntries+        <> "\nfrontier: "+        <> show (fmap (fmap fst) frontierByOperator)+        <> "\nsemantic increase: "+        <> show semanticEntryIncrease++frontierIdsUniqueAndAscending :: Ord rowId => [(rowId, row)] -> Bool+frontierIdsUniqueAndAscending rows =+  rowIds == sort rowIds+    && Set.size (Set.fromList rowIds) == length rowIds+  where+    rowIds =+      fmap fst rows++frontierRowsPresent ::+  (Ord operator, Ord rowId, Eq row) =>+  Map operator [(rowId, row)] ->+  (operator, [(rowId, row)]) ->+  Bool+frontierRowsPresent committedRowsByOperator (operator, frontierRows) =+  all+    (\(rowId, row) -> Map.lookup rowId committedRows == Just row)+    frontierRows+  where+    committedRows =+      Map.fromList (Map.findWithDefault [] operator committedRowsByOperator)++propBulkEqualsRepeated :: BulkInsertCase -> QuickCheck.Property+propBulkEqualsRepeated (BulkInsertCase baseEntries insertedEntries) =+  operatorEntrySets bulkDb QuickCheck.=== operatorEntrySets repeatedDb+  where+    baseDb =+      databaseFromEntries baseEntries+    bulkDb =+      insertTuples insertedEntries baseDb+    repeatedDb =+      foldl'+        (\database (resultKey, term) -> insertTuple resultKey term database)+        baseDb+        insertedEntries++propCompactionFixpoint :: CompactionCase -> QuickCheck.Property+propCompactionFixpoint (CompactionCase baseEntries deletedEntries) =+  QuickCheck.conjoin+    [ entrySet compactedDb QuickCheck.=== entrySet deletedDb,+      operatorRows compactedAgainDb QuickCheck.=== operatorRows compactedDb+    ]+  where+    baseDb =+      databaseFromEntries baseEntries+    deletedDb =+      foldl'+        (\database (resultKey, term) -> deleteTuple resultKey term database)+        baseDb+        deletedEntries+    compactedDb =+      compact deletedDb+    compactedAgainDb =+      compact compactedDb++propCanonicalizationMorphism :: CanonicalizationCase -> QuickCheck.Property+propCanonicalizationMorphism (CanonicalizationCase entries dirtyKeys canonicalizer) =+  QuickCheck.counterexample counterexampleText $+    QuickCheck.conjoin+      [ canonicalizationOutcome,+        deltaInsertedEntries delta QuickCheck.=== committedNewEntries+      ]+  where+    canonicalize =+      applyCanonicalizer canonicalizer+    db =+      databaseFromEntries entries+    canonicalOperatorEntrySets =+      fmap (Set.map (canonicalizeEntry canonicalize)) (operatorEntrySets db)+    canonicalizationOutcome =+      case canonicalizeDatabase canonicalize db of+        Left _residualCommands ->+          QuickCheck.property True+        Right fullyCanonicalDb ->+          operatorEntrySets fullyCanonicalDb QuickCheck.=== canonicalOperatorEntrySets+    (delta, _commands, committedDb) =+      canonicalizeDirtyRows dirtyKeys canonicalize db+    entriesAfterDeletion =+      Set.difference (entrySet db) (Set.fromList (deltaDeletedEntries delta))+    committedNewEntries =+      sort (Set.toList (Set.difference (entrySet committedDb) entriesAfterDeletion))+    counterexampleText =+      "entries: "+        <> show (entryList db)+        <> "\ndirty keys: "+        <> show dirtyKeys+        <> "\ncanonicalizer: "+        <> show canonicalizer+        <> "\ndelta inserted: "+        <> show (deltaInsertedEntries delta)+        <> "\ncommitted entries: "+        <> show (entryList committedDb)++propFreeJoinNaiveEnumeration :: FreeJoinCase -> QuickCheck.Property+propFreeJoinNaiveEnumeration (FreeJoinCase entries plan) =+  case Database.freeJoin plan db of+    Left validationError ->+      QuickCheck.counterexample (counterexampleText Set.empty <> "\nvalidation error: " <> show validationError) False+    Right (bindings, _arrangedDb) ->+      let producedBindings =+            bindingSet bindings+       in QuickCheck.counterexample (counterexampleText producedBindings) $+            QuickCheck.conjoin+              [ QuickCheck.counterexample "freeJoin produced a binding outside naive enumeration" $+                  producedBindings `Set.isSubsetOf` expectedBindings,+                producedBindings QuickCheck.=== expectedBindings+              ]+  where+    db =+      databaseFromEntries entries+    expectedBindings =+      bindingSet (naiveFreeJoinEntries plan entries)+    counterexampleText producedBindings =+      "entries: "+        <> show (entryList db)+        <> "\nplan: "+        <> showFreeJoinPlan plan+        <> "\nproduced: "+        <> show producedBindings+        <> "\nexpected: "+        <> show expectedBindings++propWatermarkDeferredIndexInterleaving :: WatermarkInterleavingCase -> QuickCheck.Property+propWatermarkDeferredIndexInterleaving (WatermarkInterleavingCase actions) =+  case foldM applyTermDatabaseAction emptyInterleavingState actions >>= validateFinalInterleavingState of+    Left mismatch ->+      QuickCheck.counterexample+        ( "actions: "+            <> show actions+            <> "\nmismatch: "+            <> show mismatch+        )+        False+    Right () ->+      QuickCheck.property True++emptyInterleavingState :: InterleavingState+emptyInterleavingState =+  InterleavingState+    { interleavingDatabase = emptyDatabase,+      interleavingReference = ReferenceTermTable Map.empty+    }++applyTermDatabaseAction ::+  InterleavingState ->+  TermDatabaseAction ->+  Either InterleavingMismatch InterleavingState+applyTermDatabaseAction state action =+  case action of+    InsertSingle entry@(resultKey, term) ->+      Right+        state+          { interleavingDatabase = insertTuple resultKey term (interleavingDatabase state),+            interleavingReference = insertReferenceEntry entry (interleavingReference state)+          }+    InsertBatch entries ->+      Right+        state+          { interleavingDatabase = insertTuples entries (interleavingDatabase state),+            interleavingReference = insertReferenceEntries entries (interleavingReference state)+          }+    DeleteExact entry@(resultKey, term) ->+      Right+        state+          { interleavingDatabase = deleteTuple resultKey term (interleavingDatabase state),+            interleavingReference = deleteReferenceEntry entry (interleavingReference state)+          }+    CompactDatabase ->+      Right+        state+          { interleavingDatabase = compact (interleavingDatabase state)+          }+    QueryEntriesForResultKey resultKey ->+      let expectedEntries =+            referenceEntriesForResultKey resultKey (interleavingReference state)+          actualEntries =+            Set.fromList (entriesForResultKey resultKey (interleavingDatabase state))+       in if actualEntries == expectedEntries+            then Right state+            else Left (ResultEntriesMismatch resultKey expectedEntries actualEntries)+    QueryTupleAll term ->+      let expectedOwners =+            referenceTupleOwners term (interleavingReference state)+          actualOwners =+            tupleLookupOwners (lookupTupleAll term (interleavingDatabase state))+       in if actualOwners == expectedOwners+            then Right state+            else Left (TupleOwnersMismatch term expectedOwners actualOwners)+    QueryFixedFreeJoin ->+      case Database.freeJoin fixedTwoAtomFreeJoinPlan (interleavingDatabase state) of+        Left validationError ->+          Left (FixedFreeJoinValidationFailure validationError)+        Right (bindings, arrangedDatabase) ->+          let expectedBindings =+                bindingSet+                  (naiveFreeJoinEntries fixedTwoAtomFreeJoinPlan (referenceEntries (interleavingReference state)))+              actualBindings =+                bindingSet bindings+           in if actualBindings == expectedBindings+                then Right state {interleavingDatabase = arrangedDatabase}+                else Left (FixedFreeJoinBindingsMismatch expectedBindings actualBindings)++validateFinalInterleavingState :: InterleavingState -> Either InterleavingMismatch ()+validateFinalInterleavingState state =+  if actualEntries == expectedEntries+    then Right ()+    else Left (FinalEntriesMismatch expectedEntries actualEntries)+  where+    expectedEntries =+      Set.fromList (referenceEntries (interleavingReference state))+    actualEntries =+      entrySet (interleavingDatabase state)++insertReferenceEntry :: (Int, TestTerm Int) -> ReferenceTermTable -> ReferenceTermTable+insertReferenceEntry (resultKey, term) (ReferenceTermTable ownersByTerm) =+  ReferenceTermTable+    (Map.insertWith Set.union term (Set.singleton resultKey) ownersByTerm)++insertReferenceEntries :: [(Int, TestTerm Int)] -> ReferenceTermTable -> ReferenceTermTable+insertReferenceEntries entries reference =+  foldl' (flip insertReferenceEntry) reference entries++deleteReferenceEntry :: (Int, TestTerm Int) -> ReferenceTermTable -> ReferenceTermTable+deleteReferenceEntry (resultKey, term) (ReferenceTermTable ownersByTerm) =+  ReferenceTermTable (Map.update deleteOwner term ownersByTerm)+  where+    deleteOwner owners =+      case Set.delete resultKey owners of+        remainingOwners+          | Set.null remainingOwners -> Nothing+          | otherwise -> Just remainingOwners++referenceEntries :: ReferenceTermTable -> [(Int, TestTerm Int)]+referenceEntries (ReferenceTermTable ownersByTerm) =+  Map.foldMapWithKey+    (\term owners -> fmap (\resultKey -> (resultKey, term)) (Set.toAscList owners))+    ownersByTerm++referenceEntriesForResultKey :: Int -> ReferenceTermTable -> Set (Int, TestTerm Int)+referenceEntriesForResultKey resultKey =+  Set.fromList . filter ((== resultKey) . fst) . referenceEntries++referenceTupleOwners :: TestTerm Int -> ReferenceTermTable -> Set Int+referenceTupleOwners term (ReferenceTermTable ownersByTerm) =+  Map.findWithDefault Set.empty term ownersByTerm++tupleLookupOwners :: TupleLookup Int -> Set Int+tupleLookupOwners tupleLookup =+  case tupleLookup of+    TupleMissing -> Set.empty+    TupleUnique resultKey -> Set.singleton resultKey+    TupleAmbiguous resultKeys -> Set.fromList (toList resultKeys)++fixedTwoAtomFreeJoinPlan :: FreeJoinPlan TestTerm Int+fixedTwoAtomFreeJoinPlan =+  FreeJoinPlan+    [ QueryAtom+        { atomOperator = binaryOperator,+          atomResult = QueryVariable (ExplicitQueryVar 0),+          atomChildren =+            [ QueryVariable (ExplicitQueryVar 1),+              QueryVariable (ExplicitQueryVar 2)+            ]+        },+      QueryAtom+        { atomOperator = binaryOperator,+          atomResult = QueryVariable (ExplicitQueryVar 3),+          atomChildren =+            [ QueryVariable (ExplicitQueryVar 2),+              QueryVariable (ExplicitQueryVar 4)+            ]+        }+    ]+  where+    binaryOperator =+      operatorFromArity 2++interleavingActionGen :: QuickCheck.Gen TermDatabaseAction+interleavingActionGen =+  QuickCheck.frequency+    [ (4, InsertSingle <$> interleavingEntryGen),+      (2, InsertBatch <$> interleavingEntryListGen 5),+      (3, DeleteExact <$> interleavingEntryGen),+      (1, pure CompactDatabase),+      (2, QueryEntriesForResultKey <$> interleavingKeyGen),+      (2, QueryTupleAll <$> interleavingTermGen),+      (2, pure QueryFixedFreeJoin)+    ]++interleavingEntryGen :: QuickCheck.Gen (Int, TestTerm Int)+interleavingEntryGen =+  (,) <$> interleavingKeyGen <*> interleavingTermGen++interleavingEntryListGen :: Int -> QuickCheck.Gen [(Int, TestTerm Int)]+interleavingEntryListGen upperBound = do+  entryCount <- QuickCheck.chooseInt (1, upperBound)+  QuickCheck.vectorOf entryCount interleavingEntryGen++interleavingKeyGen :: QuickCheck.Gen Int+interleavingKeyGen =+  QuickCheck.chooseInt (0, 7)++interleavingTermGen :: QuickCheck.Gen (TestTerm Int)+interleavingTermGen = do+  arity <- QuickCheck.chooseInt (0, 4)+  termFromArity arity <$> QuickCheck.vectorOf arity interleavingKeyGen++entryGen :: QuickCheck.Gen (Int, TestTerm Int)+entryGen =+  (,) <$> keyGen <*> termGen 4++entryListGen :: Int -> QuickCheck.Gen [(Int, TestTerm Int)]+entryListGen upperBound = do+  entryCount <- QuickCheck.chooseInt (0, upperBound)+  QuickCheck.vectorOf entryCount entryGen++keyGen :: QuickCheck.Gen Int+keyGen =+  QuickCheck.chooseInt (0, 15)++termGen :: Int -> QuickCheck.Gen (TestTerm Int)+termGen maximumArity = do+  arity <- QuickCheck.chooseInt (0, maximumArity)+  termFromArity arity <$> QuickCheck.vectorOf arity keyGen++termFromArity :: Int -> [Int] -> TestTerm Int+termFromArity arity children =+  case (arity, children) of+    (0, []) ->+      TNull+    (1, [child]) ->+      TUnary child+    (2, [leftChild, rightChild]) ->+      TBinary leftChild rightChild+    _ ->+      TNary children++operatorFromArity :: Int -> Operator TestTerm+operatorFromArity arity =+  extractOperator (termFromArity arity (replicate arity 0))++freeJoinPlanGen :: QuickCheck.Gen (FreeJoinPlan TestTerm Int)+freeJoinPlanGen = do+  atomCount <- QuickCheck.chooseInt (0, 3)+  FreeJoinPlan <$> QuickCheck.vectorOf atomCount queryAtomGen++queryAtomGen :: QuickCheck.Gen (QueryAtom TestTerm Int)+queryAtomGen = do+  arity <- QuickCheck.chooseInt (0, 3)+  QueryAtom+    <$> pure (operatorFromArity arity)+    <*> queryTermGen+    <*> QuickCheck.vectorOf arity queryTermGen++queryTermGen :: QuickCheck.Gen (QueryTerm Int)+queryTermGen =+  QuickCheck.frequency+    [ (3, QueryVariable . ExplicitQueryVar <$> QuickCheck.chooseInt (0, 4)),+      (2, QueryBound <$> keyGen)+    ]++dirtyKeySetGen :: [(Int, TestTerm Int)] -> QuickCheck.Gen IntSet+dirtyKeySetGen entries =+  case Set.toList (entryKeys entries) of+    [] ->+      pure IntSet.empty+    keys ->+      IntSet.fromList <$> QuickCheck.sublistOf keys++entryKeys :: [(Int, TestTerm Int)] -> Set Int+entryKeys =+  foldMap (\(resultKey, term) -> Set.fromList (resultKey : toList term))++applyCanonicalizer :: KeyCanonicalizer -> Int -> Int+applyCanonicalizer (KeyCanonicalizer modulus) key =+  key `mod` modulus++canonicalizeEntry :: (Int -> Int) -> (Int, TestTerm Int) -> (Int, TestTerm Int)+canonicalizeEntry canonicalize (resultKey, term) =+  (canonicalize resultKey, fmap canonicalize term)++databaseFromEntries :: [(Int, TestTerm Int)] -> Database TestTerm Int+databaseFromEntries entries =+  insertTuples entries emptyDatabase++entrySet :: Database TestTerm Int -> Set (Int, TestTerm Int)+entrySet =+  Set.fromList . databaseEntries++entryList :: Database TestTerm Int -> [(Int, TestTerm Int)]+entryList =+  sort . databaseEntries++operatorEntrySets :: Database TestTerm Int -> Map (Operator TestTerm) (Set (Int, TestTerm Int))+operatorEntrySets =+  Map.mapWithKey (\operator rows -> Set.fromList (rowEntries operator rows)) . operatorRows++rowEntries :: Operator TestTerm -> [(rowId, DatabaseRow)] -> [(Int, TestTerm Int)]+rowEntries operator =+  mapMaybe (rowEntry operator . snd)++deltaDeletedEntries :: DatabaseRowDelta TestTerm -> [(Int, TestTerm Int)]+deltaDeletedEntries =+  sort . deltaEntries . rowsDeleted++deltaInsertedEntries :: DatabaseRowDelta TestTerm -> [(Int, TestTerm Int)]+deltaInsertedEntries =+  sort . deltaEntries . rowsInserted++deltaEntries :: Map (Operator TestTerm) [(rowId, DatabaseRow)] -> [(Int, TestTerm Int)]+deltaEntries =+  Map.foldMapWithKey rowEntries++expectedInsertClosurePairs ::+  Database TestTerm Int ->+  [(Int, TestTerm Int)] ->+  Set (Int, Int)+expectedInsertClosurePairs baseDb insertedEntries =+  Map.foldlWithKey' collectTuplePairs Set.empty insertedOwnersByTuple+  where+    baseOwnersByTuple =+      tupleOwners (databaseEntries baseDb)+    insertedOwnersByTuple =+      tupleOwners insertedEntries+    collectTuplePairs pairs term insertedOwners =+      Set.union pairs $+        Set.filter+          (pairTouches insertedOwners)+          (ownerPairs (Set.union insertedOwners (Map.findWithDefault Set.empty term baseOwnersByTuple)))++tupleOwners :: [(Int, TestTerm Int)] -> Map (TestTerm Int) (Set Int)+tupleOwners =+  foldl'+    (\owners (resultKey, term) -> Map.insertWith Set.union term (Set.singleton resultKey) owners)+    Map.empty++ownerPairs :: Set Int -> Set (Int, Int)+ownerPairs owners =+  Set.fromList+    [ (leftOwner, rightOwner)+      | leftOwner <- ownerList,+        rightOwner <- ownerList,+        leftOwner < rightOwner+    ]+  where+    ownerList =+      Set.toList owners++pairTouches :: Set Int -> (Int, Int) -> Bool+pairTouches owners (leftOwner, rightOwner) =+  Set.member leftOwner owners || Set.member rightOwner owners++unionResultSet :: [TermCommand TestTerm Int] -> Set (Int, Int)+unionResultSet =+  foldMap unionPair++unionPair :: TermCommand TestTerm Int -> Set (Int, Int)+unionPair command =+  case command of+    UnionResults left right ->+      maybe Set.empty Set.singleton (orderedDistinctPair left right)+    _ ->+      Set.empty++orderedDistinctPair :: Ord key => key -> key -> Maybe (key, key)+orderedDistinctPair left right+  | left == right =+      Nothing+  | left < right =+      Just (left, right)+  | otherwise =+      Just (right, left)++termCommandsText :: [TermCommand TestTerm Int] -> [String]+termCommandsText =+  fmap termCommandText++termCommandText :: TermCommand TestTerm Int -> String+termCommandText command =+  case command of+    DeleteRow operator rowId ->+      "DeleteRow " <> show operator <> " " <> show rowId+    InsertTerm resultKey term ->+      "InsertTerm " <> show resultKey <> " " <> show term+    UnionResults left right ->+      "UnionResults " <> show left <> " " <> show right++bindingSet :: [QueryBinding Int] -> Set (Map QueryVar Int)+bindingSet =+  Set.fromList . fmap queryBindingAssignments++naiveFreeJoinEntries :: FreeJoinPlan TestTerm Int -> [(Int, TestTerm Int)] -> [QueryBinding Int]+naiveFreeJoinEntries (FreeJoinPlan atoms) entries =+  foldl'+    (\bindings atom -> foldMap (bindNaiveAtom atom) bindings)+    [QueryBinding Map.empty]+    atoms+  where+    rowsByOperator =+      entriesByOperator entries+    bindNaiveAtom atom binding =+      mapMaybe (bindNaiveEntry atom binding) (Map.findWithDefault [] (atomOperator atom) rowsByOperator)++entriesByOperator :: [(Int, TestTerm Int)] -> Map (Operator TestTerm) [(Int, TestTerm Int)]+entriesByOperator =+  Map.fromListWith (<>)+    . fmap (\entry@(_resultKey, term) -> (extractOperator term, [entry]))++bindNaiveEntry :: QueryAtom TestTerm Int -> QueryBinding Int -> (Int, TestTerm Int) -> Maybe (QueryBinding Int)+bindNaiveEntry atom binding (resultKey, term)+  | extractOperator term == atomOperator atom =+      bindNaiveValues atom binding (resultKey : toList term)+  | otherwise =+      Nothing++bindNaiveValues :: QueryAtom TestTerm Int -> QueryBinding Int -> [Int] -> Maybe (QueryBinding Int)+bindNaiveValues atom binding values+  | length terms == length values =+      foldM bindQueryTerm binding (zip terms values)+  | otherwise =+      Nothing+  where+    terms =+      atomResult atom : atomChildren atom++bindQueryTerm :: QueryBinding Int -> (QueryTerm Int, Int) -> Maybe (QueryBinding Int)+bindQueryTerm binding (term, value) =+  case term of+    QueryBound expectedValue+      | expectedValue == value ->+          Just binding+      | otherwise ->+          Nothing+    QueryVariable variable ->+      bindQueryVariable variable value binding++bindQueryVariable :: QueryVar -> Int -> QueryBinding Int -> Maybe (QueryBinding Int)+bindQueryVariable variable value binding =+  case Map.lookup variable (queryBindingAssignments binding) of+    Nothing ->+      Just binding {queryBindingAssignments = Map.insert variable value (queryBindingAssignments binding)}+    Just existingValue+      | existingValue == value ->+          Just binding+      | otherwise ->+          Nothing++showFreeJoinPlan :: FreeJoinPlan TestTerm Int -> String+showFreeJoinPlan (FreeJoinPlan atoms) =+  "FreeJoinPlan " <> show (fmap showQueryAtom atoms)++showQueryAtom :: QueryAtom TestTerm Int -> String+showQueryAtom atom =+  "{operator="+    <> show (atomOperator atom)+    <> ", result="+    <> show (atomResult atom)+    <> ", children="+    <> show (atomChildren atom)+    <> "}"
+ test/term/DatabaseSpec.hs view
@@ -0,0 +1,735 @@+{-# LANGUAGE DeriveTraversable #-}++module DatabaseSpec+  ( tests,+  )+where++import Data.List.NonEmpty (NonEmpty (..))+import Data.IntSet qualified as IntSet+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Moonlight.Core (Pattern (..))+import Moonlight.Core qualified as EGraph+import Moonlight.Core+  ( Database,+    DatabaseRowDelta (..),+    ArrangementValidationError (..),+    Column (..),+    FreeJoinPlan (..),+    Operator (..),+    PatternFreeJoinPlan (..),+    QueryAtom (..),+    QueryBinding (..),+    QueryTerm (..),+    QueryVar (..),+    RelationStats (..),+    TermCommitResult (..),+    TermCommand (..),+    TupleLookup (..),+    arrangementKeyForOperator,+    arrangementPrefixForKey,+    compact,+    compilePatternFreeJoinPlan,+    compilePatternsFreeJoinPlan,+    databaseEntries,+    entriesForResultKey,+    arrangementRowsForPrefix,+    editorCompact,+    editorDeleteTuple,+    editorInsertTuple,+    freeJoin,+    relationStats,+    rowChildren,+    rowResult,+    rowsForOperator,+    deleteRow,+    deleteTuple,+    emptyDatabase,+    insertTuples,+    insertTuple,+    lookupTupleAll,+    lookupLeastTuple,+    rehydrateTuple,+    commitTermCommands,+    abortTransaction,+    runCommandTransaction,+  )+import Moonlight.Core+  ( canonicalizeDatabase,+    canonicalizeDirtyRowsInEditor,+  )+import DatabaseLawSpec qualified as DatabaseLawSpec+import Prelude+import System.Mem.StableName (makeStableName)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), assertBool, assertFailure, testCase)++data TestTerm key+  = TNull+  | TUnary !key+  | TBinary !key !key+  | TNary [key]+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)++tests :: TestTree+tests =+  testGroup+    "Moonlight.Core.Term.Database"+    [ databaseEntriesRoundTrip,+      databaseChunkBoundaryTombstones,+      databaseResultFilter,+      databaseChildLookup,+      databaseTupleDeleteRemovesOnlyExactOwner,+      databaseArrangementPrefixLookup,+      databaseAbsentDeletePreservesArrangementCache,+      databaseArrangementValidationRejectsInvalidShapes,+      databaseRelationStatsSummarizeLiveRows,+      databaseFreeJoinUsesBoundPrefixAndEquality,+      databaseFreeJoinGluesMultiAtomBindings,+      databasePatternCompilationMatchesNestedPattern,+      databasePatternCompilationSeparatesVariableNamespaces,+      databasePatternCompilationGluesMultiplePatterns,+      databaseBulkInsertMatchesRepeatedInsert,+      databaseCommandBatchUnionsAmbiguousInserts,+      databaseCommandBatchUnionsExistingAndBatchOwners,+      databaseTransactionCommitsDeferredEdits,+      databaseTransactionAbortPreservesSnapshot,+      databaseTransactionQueuesDirtyCanonicalization,+      databaseCanonicalizationDeltaReportsCommittedInsertions,+      databaseCompactionDropsTombstoneSlots,+      rehydrateTupleArity,+      canonicalizeDatabaseRewritesKeys,+      canonicalizeDatabaseSurfacesResidualUnions,+      DatabaseLawSpec.tests+    ]++databaseEntriesRoundTrip :: TestTree+databaseEntriesRoundTrip =+  testCase "entries rehydrates nullary, unary, binary, and n-ary entries" $+    entrySet db+      @?= Set.fromList+        [ (1, TNull),+          (2, TUnary 10),+          (3, TBinary 11 12),+          (4, TNary [13, 14, 15])+        ]+  where+    db =+        insertNode (TNary [13, 14, 15]) 4 $+        insertNode (TBinary 11 12) 3 $+          insertNode (TUnary 10) 2 $+            insertNode TNull 1 emptyDatabase++databaseChunkBoundaryTombstones :: TestTree+databaseChunkBoundaryTombstones =+  testCase "column chunks, pending rows, tombstones, and compaction glue to one row set" $ do+    entrySet deletedDatabase @?= expectedEntries+    entrySet compactedDatabase @?= expectedEntries+    length (rowsForOperator naryOperator compactedDatabase) @?= Set.size expectedEntries+  where+    entries =+      fmap chunkBoundaryEntry [0 .. 1030]+    fullDatabase =+      foldl'+        (\database (resultKey, term) -> insertTuple resultKey term database)+        emptyDatabase+        entries+    selectedRowIds =+      fmap fst $+        take 1 operatorTableRows+          <> take 1 (drop 511 operatorTableRows)+          <> take 1 (drop 1024 operatorTableRows)+    operatorTableRows =+      rowsForOperator naryOperator fullDatabase+    deletedDatabase =+      foldl'+        (\database rowId -> deleteRow naryOperator rowId database)+        fullDatabase+        selectedRowIds+    compactedDatabase =+      compact deletedDatabase+    expectedEntries =+      Set.difference+        (Set.fromList entries)+        (Set.fromList (fmap chunkBoundaryEntry [0, 511, 1024]))+    naryOperator =+      Operator (TNary [(), (), ()])+    chunkBoundaryEntry :: Int -> (Int, TestTerm Int)+    chunkBoundaryEntry resultKey =+      (resultKey, TNary [resultKey + 1, resultKey + 2, resultKey + 3])++databaseResultFilter :: TestTree+databaseResultFilter =+  testCase "entriesForResultKey filters by encoded result key" $+    Set.fromList (entriesForResultKey 3 db)+      @?= Set.fromList+        [ (3, TBinary 11 12)+        ]+  where+    db =+      insertNode (TBinary 11 12) 3 $+        insertNode (TBinary 11 13) 4 emptyDatabase++databaseChildLookup :: TestTree+databaseChildLookup =+  testCase "database tuple lookup exposes ambiguous and least-result policy" $ do+    lookupTupleAll (TBinary 11 12) db @?= TupleAmbiguous (3 :| [5])+    lookupLeastTuple (TBinary 11 12) db @?= Just 3+    lookupTupleAll (TBinary 9 9) db @?= TupleMissing+    lookupLeastTuple (TBinary 9 9) db @?= Nothing+  where+    db =+      insertNode (TBinary 11 12) 5 $+        insertNode (TBinary 11 12) 3 $+          insertNode (TBinary 12 11) 7 emptyDatabase++databaseTupleDeleteRemovesOnlyExactOwner :: TestTree+databaseTupleDeleteRemovesOnlyExactOwner =+  testCase "deleteTuple removes only the exact result and children row" $ do+    entrySet deletedDb+      @?= Set.fromList+        [ (5, TBinary 11 12),+          (7, TBinary 12 11)+        ]+    lookupTupleAll (TBinary 11 12) deletedDb @?= TupleUnique 5+  where+    deletedDb =+      deleteTuple 3 (TBinary 11 12) db++    db =+      insertNode (TBinary 11 12) 5 $+        insertNode (TBinary 11 12) 3 $+          insertNode (TBinary 12 11) 7 emptyDatabase++databaseArrangementPrefixLookup :: TestTree+databaseArrangementPrefixLookup =+  testCase "lazy arrangement prefix lookup materializes requested prefixes on demand" $ do+    exactBinaryKey <-+      expectRight (arrangementKeyForOperator binaryOperator [ChildColumn 0, ChildColumn 1, ResultColumn])+    firstPrefix <-+      expectRight (arrangementPrefixForKey exactBinaryKey [11])+    (firstChildRows, arrangedDb) <-+      expectRight (arrangementRowsForPrefix binaryOperator exactBinaryKey firstPrefix db)+    siblingPrefix <-+      expectRight (arrangementPrefixForKey exactBinaryKey [12])+    (siblingRows, _cachedDb) <-+      expectRight (arrangementRowsForPrefix binaryOperator exactBinaryKey siblingPrefix arrangedDb)+    fmap (rowResult . snd) firstChildRows @?= [3, 5]+    fmap (rowResult . snd) siblingRows @?= [7]+  where+    db =+      insertNode (TBinary 11 12) 5 $+        insertNode (TBinary 11 12) 3 $+          insertNode (TBinary 12 11) 7 emptyDatabase++databaseAbsentDeletePreservesArrangementCache :: TestTree+databaseAbsentDeletePreservesArrangementCache =+  testCase "absent tuple deletion returns the arrangement-bearing database unchanged" $ do+    exactBinaryKey <-+      expectRight (arrangementKeyForOperator binaryOperator [ChildColumn 0, ChildColumn 1, ResultColumn])+    prefix <-+      expectRight (arrangementPrefixForKey exactBinaryKey [11])+    (_rows, arrangedDb) <-+      expectRight (arrangementRowsForPrefix binaryOperator exactBinaryKey prefix db)+    let unchangedDb =+          deleteTuple 99 (TBinary 90 91) arrangedDb+    arrangedDb `seq` unchangedDb `seq` pure ()+    arrangedName <- makeStableName arrangedDb+    unchangedName <- makeStableName unchangedDb+    assertBool "absent deletion rebuilt the database and discarded cached arrangements" (arrangedName == unchangedName)+  where+    db =+      insertNode (TBinary 11 12) 3 emptyDatabase++databaseArrangementValidationRejectsInvalidShapes :: TestTree+databaseArrangementValidationRejectsInvalidShapes =+  testCase "arrangement construction rejects invalid columns, prefixes, and operator reuse" $ do+    arrangementKeyForOperator binaryOperator [ChildColumn (-1)]+      @?= Left (NegativeArrangementChildColumn (-1))+    arrangementKeyForOperator binaryOperator [ChildColumn 2]+      @?= Left (ArrangementChildColumnOutOfBounds 2 2)+    unaryKey <-+      expectRight (arrangementKeyForOperator unaryOperator [ChildColumn 0])+    arrangementPrefixForKey unaryKey [10, 11]+      @?= Left (ArrangementPrefixTooDeep 2 1)+    emptyPrefix <-+      expectRight (arrangementPrefixForKey unaryKey [])+    case arrangementRowsForPrefix binaryOperator unaryKey emptyPrefix emptyDatabase of+      Left mismatch ->+        mismatch @?= ArrangementOperatorArityMismatch 1 2+      Right _fabricatedRows ->+        assertFailure "arrangement key for a unary operator was accepted by a binary operator"++databaseRelationStatsSummarizeLiveRows :: TestTree+databaseRelationStatsSummarizeLiveRows =+  testCase "relationStats reports live prefix and bucket cardinalities" $ do+    exactBinaryKey <-+      expectRight (arrangementKeyForOperator binaryOperator [ChildColumn 0, ChildColumn 1])+    statsResult <-+      expectRight (relationStats [exactBinaryKey] binaryOperator db)+    case statsResult of+      Just stats -> do+        rowCount stats @?= 3+        liveRowCount stats @?= 3+        distinctPerPrefix stats @?= Map.singleton exactBinaryKey 2+        maximumBucketSize stats @?= 2+      Nothing ->+        assertFailure "expected relation stats for binary operator"+  where+    db =+      insertNode (TBinary 11 12) 5 $+        insertNode (TBinary 11 12) 3 $+          insertNode (TBinary 12 11) 7 emptyDatabase++databaseFreeJoinUsesBoundPrefixAndEquality :: TestTree+databaseFreeJoinUsesBoundPrefixAndEquality =+  testCase "freeJoin uses bound-prefix probes and repeated-variable equality" $ do+    (bindings, _arrangedDb) <- expectRight joinResult+    bindingSet bindings+      @?= Set.fromList+        [ Map.fromList+            [ (ExplicitQueryVar 0, 1),+              (ExplicitQueryVar 1, 10)+            ]+        ]+  where+    joinResult =+      freeJoin+        ( FreeJoinPlan+            [ QueryAtom+                { atomOperator = binaryOperator,+                  atomResult = QueryVariable (ExplicitQueryVar 0),+                  atomChildren =+                    [ QueryVariable (ExplicitQueryVar 1),+                      QueryVariable (ExplicitQueryVar 1)+                    ]+                }+            ]+        )+        db++    db =+      insertNode (TBinary 10 10) 1 $+        insertNode (TBinary 10 11) 2 emptyDatabase++databaseFreeJoinGluesMultiAtomBindings :: TestTree+databaseFreeJoinGluesMultiAtomBindings =+  testCase "freeJoin glues compatible bindings across atoms" $ do+    (bindings, _arrangedDb) <- expectRight joinResult+    bindingSet bindings+      @?= Set.fromList+        [ Map.fromList+            [ (ExplicitQueryVar 0, 100),+              (ExplicitQueryVar 1, 1),+              (ExplicitQueryVar 2, 2),+              (ExplicitQueryVar 3, 101),+              (ExplicitQueryVar 4, 3)+            ]+        ]+  where+    joinResult =+      freeJoin+        ( FreeJoinPlan+            [ QueryAtom+                { atomOperator = binaryOperator,+                  atomResult = QueryVariable (ExplicitQueryVar 0),+                  atomChildren =+                    [ QueryVariable (ExplicitQueryVar 1),+                      QueryVariable (ExplicitQueryVar 2)+                    ]+                },+              QueryAtom+                { atomOperator = binaryOperator,+                  atomResult = QueryVariable (ExplicitQueryVar 3),+                  atomChildren =+                    [ QueryVariable (ExplicitQueryVar 2),+                      QueryVariable (ExplicitQueryVar 4)+                    ]+                }+            ]+        )+        db++    db =+      insertNode (TBinary 1 2) 100 $+        insertNode (TBinary 2 3) 101 $+          insertNode (TBinary 8 9) 102 emptyDatabase++databasePatternCompilationMatchesNestedPattern :: TestTree+databasePatternCompilationMatchesNestedPattern =+  testCase "compilePatternFreeJoinPlan lowers nested repeated variables into relation atoms" $ do+    (bindings, _arrangedDb) <- expectRight joinResult+    patternFreeJoinRoots compiled+      @?= QueryVariable (GeneratedPatternNodeVar 0) :| []+    patternFreeJoinVariables compiled+      @?= Map.singleton (EGraph.mkPatternVar 0) (AuthoredPatternVar (EGraph.mkPatternVar 0))+    bindingSet bindings+      @?= Set.fromList+        [ Map.fromList+            [ (AuthoredPatternVar (EGraph.mkPatternVar 0), 10),+              (GeneratedPatternNodeVar 0, 100),+              (GeneratedPatternNodeVar 1, 11)+            ]+        ]+  where+    compiled :: PatternFreeJoinPlan TestTerm Int+    compiled =+      compilePatternFreeJoinPlan+        ( PatternNode+            ( TBinary+                (PatternVar (EGraph.mkPatternVar 0))+                (PatternNode (TUnary (PatternVar (EGraph.mkPatternVar 0))))+            )+        )++    joinResult =+      freeJoin (patternFreeJoinPlan compiled) db++    db =+      insertNode (TBinary 10 11) 100 $+        insertNode (TUnary 10) 11 $+          insertNode (TBinary 10 12) 101 $+            insertNode (TUnary 20) 12 emptyDatabase++databasePatternCompilationSeparatesVariableNamespaces :: TestTree+databasePatternCompilationSeparatesVariableNamespaces =+  testCase "pattern compilation keeps authored and generated query variables disjoint" $ do+    patternFreeJoinVariables compiled+      @?= Map.fromList+        [ (EGraph.mkPatternVar 0, AuthoredPatternVar (EGraph.mkPatternVar 0)),+          (EGraph.mkPatternVar maxBound, AuthoredPatternVar (EGraph.mkPatternVar maxBound))+        ]+    patternFreeJoinRoots compiled+      @?= QueryVariable (GeneratedPatternNodeVar 0) :| []+    (bindings, _arrangedDatabase) <- expectRight (freeJoin (patternFreeJoinPlan compiled) database)+    bindingSet bindings+      @?= Set.singleton+        ( Map.fromList+            [ (AuthoredPatternVar (EGraph.mkPatternVar 0), 10),+              (AuthoredPatternVar (EGraph.mkPatternVar maxBound), 20),+              (GeneratedPatternNodeVar 0, 100)+            ]+        )+  where+    compiled :: PatternFreeJoinPlan TestTerm Int+    compiled =+      compilePatternFreeJoinPlan+        ( PatternNode+            ( TBinary+                (PatternVar (EGraph.mkPatternVar 0))+                (PatternVar (EGraph.mkPatternVar maxBound))+            )+        )++    database =+      insertNode (TBinary 10 20) 100 emptyDatabase++databasePatternCompilationGluesMultiplePatterns :: TestTree+databasePatternCompilationGluesMultiplePatterns =+  testCase "compilePatternsFreeJoinPlan shares pattern variables across conjunctive roots" $ do+    (bindings, _arrangedDb) <- expectRight joinResult+    bindingSet bindings+      @?= Set.fromList+        [ Map.fromList+            [ (AuthoredPatternVar (EGraph.mkPatternVar 0), 10),+              (AuthoredPatternVar (EGraph.mkPatternVar 1), 20),+              (GeneratedPatternNodeVar 0, 100),+              (GeneratedPatternNodeVar 1, 200)+            ]+        ]+  where+    compiled :: PatternFreeJoinPlan TestTerm Int+    compiled =+      compilePatternsFreeJoinPlan+        ( PatternNode (TBinary (PatternVar (EGraph.mkPatternVar 0)) (PatternVar (EGraph.mkPatternVar 1)))+            :| [PatternNode (TUnary (PatternVar (EGraph.mkPatternVar 1)))]+        )++    joinResult =+      freeJoin (patternFreeJoinPlan compiled) db++    db =+      insertNode (TBinary 10 20) 100 $+        insertNode (TBinary 20 10) 101 $+          insertNode (TUnary 20) 200 emptyDatabase++databaseBulkInsertMatchesRepeatedInsert :: TestTree+databaseBulkInsertMatchesRepeatedInsert =+  testCase "insertTuples preserves repeated insertTuple semantics" $+    entrySet bulkDb @?= entrySet repeatedDb+  where+    entries =+      [ (1, TNull),+        (2, TUnary 10),+        (3, TBinary 11 12),+        (5, TBinary 11 12),+        (4, TNary [13, 14, 15])+      ]++    bulkDb =+      insertTuples entries emptyDatabase++    repeatedDb =+      foldl'+        (\database (resultKey, node) -> insertTuple resultKey node database)+        emptyDatabase+        entries++databaseCommandBatchUnionsAmbiguousInserts :: TestTree+databaseCommandBatchUnionsAmbiguousInserts =+  testCase "commitTermCommands coalesces batched inserts without dropping ambiguity unions" $ do+    unionResultSet (residualCommands commandResult) @?= Set.singleton (3, 5)+    fmap (rowResult . snd) (Map.findWithDefault [] binaryOperator (insertedRows commandResult))+      @?= [3, 5]+    lookupTupleAll (TBinary 11 12) (committedDatabase commandResult) @?= TupleAmbiguous (3 :| [5])+  where+    commandResult :: TermCommitResult TestTerm Int+    commandResult =+      commitTermCommands+        [ InsertTerm 5 (TBinary 11 12),+          InsertTerm 3 (TBinary 11 12)+        ]+        emptyDatabase++databaseCommandBatchUnionsExistingAndBatchOwners :: TestTree+databaseCommandBatchUnionsExistingAndBatchOwners =+  testCase "commitTermCommands preserves existing owners while coalescing a batch" $ do+    unionResultSet (residualCommands commandResult) @?= Set.fromList [(3, 5), (3, 7), (5, 7)]+    fmap (rowResult . snd) (Map.findWithDefault [] binaryOperator (insertedRows commandResult))+      @?= [3, 5]+    lookupTupleAll (TBinary 11 12) (committedDatabase commandResult) @?= TupleAmbiguous (3 :| [5, 7])+  where+    baseDb =+      insertNode (TBinary 11 12) 7 emptyDatabase++    commandResult :: TermCommitResult TestTerm Int+    commandResult =+      commitTermCommands+        [ InsertTerm 5 (TBinary 11 12),+          InsertTerm 3 (TBinary 11 12)+        ]+        baseDb++databaseTransactionCommitsDeferredEdits :: TestTree+databaseTransactionCommitsDeferredEdits =+  testCase "runCommandTransaction commits deferred row edits at the sealed boundary" $+    entrySet committedDb+      @?= Set.fromList [(2, TNull)]+  where+    baseDb =+      insertNode (TBinary 1 2) 1 emptyDatabase++    (_result, _residualCommands, committedDb) =+      runCommandTransaction baseDb $ \editor -> do+        editorDeleteTuple 1 (TBinary 1 2) editor+        editorInsertTuple 2 TNull editor+        editorCompact editor++databaseTransactionAbortPreservesSnapshot :: TestTree+databaseTransactionAbortPreservesSnapshot =+  testCase "abortTransaction discards deferred edits" $+    entrySet abortedDb @?= Set.empty+  where+    (_result, _residualCommands, abortedDb) =+      runCommandTransaction (emptyDatabase :: Database TestTerm Int) $ \editor -> do+        editorInsertTuple 1 TNull editor+        abortTransaction editor++databaseTransactionQueuesDirtyCanonicalization :: TestTree+databaseTransactionQueuesDirtyCanonicalization =+  testCase "canonicalizeDirtyRowsInEditor queues canonical row commands" $+    entrySet canonicalDb+      @?= Set.fromList+        [ (1, TBinary 2 3),+          (4, TUnary 2)+        ]+  where+    db =+      insertNode (TBinary 20 3) 10 $+        insertNode (TUnary 20) 40 emptyDatabase++    (_deltaAndCommands, _residualCommands, canonicalDb) =+      runCommandTransaction db $+        canonicalizeDirtyRowsInEditor (IntSet.fromList [10, 20, 40]) canonicalize++    canonicalize :: Int -> Int+    canonicalize key =+      case key of+        10 -> 1+        20 -> 2+        40 -> 4+        other -> other++databaseCanonicalizationDeltaReportsCommittedInsertions :: TestTree+databaseCanonicalizationDeltaReportsCommittedInsertions =+  testCase "canonicalization delta reports committed inserted rows, not collapsed candidates" $ do+    rowsInserted collapsedDelta @?= Map.empty+    case Map.elems (rowsInserted insertedDelta) of+      [[(_rowId, insertedRow)]] -> do+        rowResult insertedRow @?= 3+        rowChildren insertedRow @?= [2]+      insertedRows ->+        assertFailure ("expected one committed inserted row, got " <> show insertedRows)+  where+    collapsedDb =+      insertNode (TUnary 2) 3 $+        insertNode (TUnary 2) 1 emptyDatabase++    ((collapsedDelta, _collapsedCommands), _collapsedResidualCommands, _collapsedCanonicalDb) =+      runCommandTransaction collapsedDb $+        canonicalizeDirtyRowsInEditor (IntSet.singleton 3) collapseToExisting++    collapseToExisting :: Int -> Int+    collapseToExisting key =+      case key of+        3 -> 1+        other -> other++    insertedDb =+      insertNode (TUnary 20) 3 emptyDatabase++    ((insertedDelta, _insertedCommands), _insertedResidualCommands, _insertedCanonicalDb) =+      runCommandTransaction insertedDb $+        canonicalizeDirtyRowsInEditor (IntSet.fromList [20]) rewriteChild++    rewriteChild :: Int -> Int+    rewriteChild key =+      case key of+        20 -> 2+        other -> other++databaseCompactionDropsTombstoneSlots :: TestTree+databaseCompactionDropsTombstoneSlots =+  testCase "compact preserves entries and rekeys live rows after deletion" $+    case rowsForOperator binaryOperator fullDb of+      (deletedRowId, _) : _ -> do+        let deletedDb =+              deleteRow binaryOperator deletedRowId fullDb+            compactedDb =+              compact deletedDb+            deletedRowIds =+              fmap fst (rowsForOperator binaryOperator deletedDb)+            compactedRowIds =+              fmap fst (rowsForOperator binaryOperator compactedDb)+        entrySet compactedDb @?= entrySet deletedDb+        assertBool+          "compaction should rebuild live rows into fresh contiguous row ids"+          (deletedRowIds /= compactedRowIds)+      [] ->+        assertFailure "expected rows before compaction"+  where+    fullDb =+      insertNode (TBinary 3 4) 2 $+        insertNode (TBinary 1 2) 1 emptyDatabase++rehydrateTupleArity :: TestTree+rehydrateTupleArity =+  testCase "rehydrateTuple accepts exactly one result plus template arity children" $ do+    rehydrateBinaryTuple [7, 1, 2]+      @?= Just (7, TBinary 1 2)+    rehydrateBinaryTuple [7, 1]+      @?= Nothing+    rehydrateBinaryTuple [7, 1, 2, 3]+      @?= Nothing+    rehydrateBinaryTuple []+      @?= Nothing+  where+    rehydrateBinaryTuple :: [Int] -> Maybe (Int, TestTerm Int)+    rehydrateBinaryTuple =+      rehydrateTuple binaryOperator++binaryOperator :: Operator TestTerm+binaryOperator =+  Operator (TBinary () ())++unaryOperator :: Operator TestTerm+unaryOperator =+  Operator (TUnary ())++expectRight :: Either ArrangementValidationError value -> IO value+expectRight eitherValue =+  case eitherValue of+    Left validationError ->+      assertFailure ("unexpected arrangement validation failure: " <> show validationError)+    Right value ->+      pure value++canonicalizeDatabaseRewritesKeys :: TestTree+canonicalizeDatabaseRewritesKeys =+  testCase "canonicalizeDatabase rewrites every encoded key through the canonicalizer" $+    case canonicalDb of+      Left _residualCommands ->+        assertFailure "congruence-closed canonicalization returned residual commands"+      Right rewrittenDb ->+        entrySet rewrittenDb+          @?= Set.fromList+            [ (1, TBinary 2 3),+              (4, TUnary 2)+            ]+  where+    db =+      insertNode (TBinary 20 3) 10 $+        insertNode (TUnary 20) 40 emptyDatabase++    canonicalize :: Int -> Int+    canonicalize key =+      case key of+        10 -> 1+        20 -> 2+        40 -> 4+        other -> other++    canonicalDb =+      canonicalizeDatabase canonicalize db++canonicalizeDatabaseSurfacesResidualUnions :: TestTree+canonicalizeDatabaseSurfacesResidualUnions =+  testCase "canonicalizeDatabase refuses to discard residual congruence unions" $+    case canonicalizeDatabase collapseToExisting db of+      Left [UnionResults left right] ->+        Set.fromList [left, right] @?= Set.fromList [1, 3]+      Left _otherCommands ->+        assertFailure "expected exactly one residual union command"+      Right _database ->+        assertFailure "non-congruence-closed canonicalization fabricated success"+  where+    db =+      insertNode (TUnary 2) 3 $+        insertNode (TUnary 4) 1 emptyDatabase++    collapseToExisting :: Int -> Int+    collapseToExisting key =+      case key of+        4 -> 2+        other -> other++insertNode ::+  TestTerm Int ->+  Int ->+  Database TestTerm Int ->+  Database TestTerm Int+insertNode node resultKey =+  insertTuple resultKey node++entrySet ::+  Database TestTerm Int ->+  Set.Set (Int, TestTerm Int)+entrySet =+  Set.fromList . databaseEntries++bindingSet :: [QueryBinding Int] -> Set.Set (Map.Map QueryVar Int)+bindingSet =+  Set.fromList . fmap queryBindingAssignments++unionResultSet :: Ord key => [TermCommand f key] -> Set.Set (key, key)+unionResultSet =+  foldr collectUnionResult Set.empty+  where+    collectUnionResult :: Ord key => TermCommand f key -> Set.Set (key, key) -> Set.Set (key, key)+    collectUnionResult command pairs =+      case command of+        UnionResults left right ->+          Set.insert (left, right) pairs+        _ ->+          pairs
+ test/term/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import qualified TermTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain TermTests.tests
+ test/term/TermTests.hs view
@@ -0,0 +1,14 @@+module TermTests+  ( tests,+  )+where++import qualified DatabaseSpec as DatabaseSpec+import Test.Tasty (TestTree, testGroup)++tests :: TestTree+tests =+  testGroup+    "moonlight-core-term"+    [ DatabaseSpec.tests+    ]