diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,28 @@ +# Changelog + +## 0.1.0.0 - 2026-07-12 + +- Initial release of the 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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 The Blue Rose, Rosalia Fialkova + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,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`. diff --git a/bench/aggregate/Main.hs b/bench/aggregate/Main.hs new file mode 100644 --- /dev/null +++ b/bench/aggregate/Main.hs @@ -0,0 +1,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 + ] diff --git a/bench/basis/BasisBench.hs b/bench/basis/BasisBench.hs new file mode 100644 --- /dev/null +++ b/bench/basis/BasisBench.hs @@ -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 diff --git a/bench/basis/Main.hs b/bench/basis/Main.hs new file mode 100644 --- /dev/null +++ b/bench/basis/Main.hs @@ -0,0 +1,11 @@ +module Main + ( main, + ) +where + +import BasisBench (basisBenchmarks) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [basisBenchmarks] diff --git a/bench/numeric/Main.hs b/bench/numeric/Main.hs new file mode 100644 --- /dev/null +++ b/bench/numeric/Main.hs @@ -0,0 +1,11 @@ +module Main + ( main, + ) +where + +import NumericBench (numericBenchmarks) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [numericBenchmarks] diff --git a/bench/numeric/NumericBench.hs b/bench/numeric/NumericBench.hs new file mode 100644 --- /dev/null +++ b/bench/numeric/NumericBench.hs @@ -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 diff --git a/bench/solver/Main.hs b/bench/solver/Main.hs new file mode 100644 --- /dev/null +++ b/bench/solver/Main.hs @@ -0,0 +1,11 @@ +module Main + ( main, + ) +where + +import SolverBench (solverBenchmarks) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [solverBenchmarks] diff --git a/bench/solver/SolverBench.hs b/bench/solver/SolverBench.hs new file mode 100644 --- /dev/null +++ b/bench/solver/SolverBench.hs @@ -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) diff --git a/bench/support/BenchSupport.hs b/bench/support/BenchSupport.hs new file mode 100644 --- /dev/null +++ b/bench/support/BenchSupport.hs @@ -0,0 +1,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 diff --git a/bench/syntax/Main.hs b/bench/syntax/Main.hs new file mode 100644 --- /dev/null +++ b/bench/syntax/Main.hs @@ -0,0 +1,11 @@ +module Main + ( main, + ) +where + +import SyntaxBench (syntaxBenchmarks) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [syntaxBenchmarks] diff --git a/bench/syntax/SyntaxBench.hs b/bench/syntax/SyntaxBench.hs new file mode 100644 --- /dev/null +++ b/bench/syntax/SyntaxBench.hs @@ -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 diff --git a/bench/term/Main.hs b/bench/term/Main.hs new file mode 100644 --- /dev/null +++ b/bench/term/Main.hs @@ -0,0 +1,11 @@ +module Main + ( main, + ) +where + +import TermBench (termBenchmarks) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [termBenchmarks] diff --git a/bench/term/TermBench.hs b/bench/term/TermBench.hs new file mode 100644 --- /dev/null +++ b/bench/term/TermBench.hs @@ -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 diff --git a/moonlight-core.cabal b/moonlight-core.cabal new file mode 100644 --- /dev/null +++ b/moonlight-core.cabal @@ -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 diff --git a/src-automata/Moonlight/Automata/Pure/Algebra.hs b/src-automata/Moonlight/Automata/Pure/Algebra.hs new file mode 100644 --- /dev/null +++ b/src-automata/Moonlight/Automata/Pure/Algebra.hs @@ -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) + } diff --git a/src-automata/Moonlight/Automata/Pure/Coalgebra.hs b/src-automata/Moonlight/Automata/Pure/Coalgebra.hs new file mode 100644 --- /dev/null +++ b/src-automata/Moonlight/Automata/Pure/Coalgebra.hs @@ -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 diff --git a/src-automata/Moonlight/Automata/Pure/Core.hs b/src-automata/Moonlight/Automata/Pure/Core.hs new file mode 100644 --- /dev/null +++ b/src-automata/Moonlight/Automata/Pure/Core.hs @@ -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 + } diff --git a/src-automata/Moonlight/Automata/Pure/Transducer.hs b/src-automata/Moonlight/Automata/Pure/Transducer.hs new file mode 100644 --- /dev/null +++ b/src-automata/Moonlight/Automata/Pure/Transducer.hs @@ -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 + ) diff --git a/src-automata/Moonlight/Core/Pattern/Automata.hs b/src-automata/Moonlight/Core/Pattern/Automata.hs new file mode 100644 --- /dev/null +++ b/src-automata/Moonlight/Core/Pattern/Automata.hs @@ -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) diff --git a/src-automata/Moonlight/Core/Pattern/Kernel.hs b/src-automata/Moonlight/Core/Pattern/Kernel.hs new file mode 100644 --- /dev/null +++ b/src-automata/Moonlight/Core/Pattern/Kernel.hs @@ -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 diff --git a/src-basis/Moonlight/Core/Aggregate.hs b/src-basis/Moonlight/Core/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Aggregate.hs @@ -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) + _ -> + [] diff --git a/src-basis/Moonlight/Core/Boundary.hs b/src-basis/Moonlight/Core/Boundary.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Boundary.hs @@ -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 diff --git a/src-basis/Moonlight/Core/Capability.hs b/src-basis/Moonlight/Core/Capability.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Capability.hs @@ -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) diff --git a/src-basis/Moonlight/Core/Cardinality.hs b/src-basis/Moonlight/Core/Cardinality.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Cardinality.hs @@ -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 #-} diff --git a/src-basis/Moonlight/Core/Dedup.hs b/src-basis/Moonlight/Core/Dedup.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Dedup.hs @@ -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)) diff --git a/src-basis/Moonlight/Core/DenseKey.hs b/src-basis/Moonlight/Core/DenseKey.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/DenseKey.hs @@ -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 diff --git a/src-basis/Moonlight/Core/DomainId.hs b/src-basis/Moonlight/Core/DomainId.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/DomainId.hs @@ -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 diff --git a/src-basis/Moonlight/Core/DomainId/Internal.hs b/src-basis/Moonlight/Core/DomainId/Internal.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/DomainId/Internal.hs @@ -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) diff --git a/src-basis/Moonlight/Core/Error.hs b/src-basis/Moonlight/Core/Error.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Error.hs @@ -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 diff --git a/src-basis/Moonlight/Core/Finite.hs b/src-basis/Moonlight/Core/Finite.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Finite.hs @@ -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) diff --git a/src-basis/Moonlight/Core/Hash.hs b/src-basis/Moonlight/Core/Hash.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Hash.hs @@ -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) diff --git a/src-basis/Moonlight/Core/Identifier.hs b/src-basis/Moonlight/Core/Identifier.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Identifier.hs @@ -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 == '_' diff --git a/src-basis/Moonlight/Core/Identifier/EGraph.hs b/src-basis/Moonlight/Core/Identifier/EGraph.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Identifier/EGraph.hs @@ -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 diff --git a/src-basis/Moonlight/Core/IsoNorm.hs b/src-basis/Moonlight/Core/IsoNorm.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/IsoNorm.hs @@ -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 diff --git a/src-basis/Moonlight/Core/LawName.hs b/src-basis/Moonlight/Core/LawName.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/LawName.hs @@ -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 diff --git a/src-basis/Moonlight/Core/MapAccum.hs b/src-basis/Moonlight/Core/MapAccum.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/MapAccum.hs @@ -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] diff --git a/src-basis/Moonlight/Core/MapInvert.hs b/src-basis/Moonlight/Core/MapInvert.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/MapInvert.hs @@ -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) diff --git a/src-basis/Moonlight/Core/Match.hs b/src-basis/Moonlight/Core/Match.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Match.hs @@ -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 + } diff --git a/src-basis/Moonlight/Core/ModuleIdentifier.hs b/src-basis/Moonlight/Core/ModuleIdentifier.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/ModuleIdentifier.hs @@ -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 ".") diff --git a/src-basis/Moonlight/Core/OrdCollection.hs b/src-basis/Moonlight/Core/OrdCollection.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/OrdCollection.hs @@ -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 diff --git a/src-basis/Moonlight/Core/Order.hs b/src-basis/Moonlight/Core/Order.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Order.hs @@ -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 diff --git a/src-basis/Moonlight/Core/ProofManifest.hs b/src-basis/Moonlight/Core/ProofManifest.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/ProofManifest.hs @@ -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 = '?' diff --git a/src-basis/Moonlight/Core/Queue.hs b/src-basis/Moonlight/Core/Queue.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Queue.hs @@ -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 diff --git a/src-basis/Moonlight/Core/Refinement.hs b/src-basis/Moonlight/Core/Refinement.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Refinement.hs @@ -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) diff --git a/src-basis/Moonlight/Core/Relational.hs b/src-basis/Moonlight/Core/Relational.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Relational.hs @@ -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 diff --git a/src-basis/Moonlight/Core/Scan.hs b/src-basis/Moonlight/Core/Scan.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Scan.hs @@ -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 diff --git a/src-basis/Moonlight/Core/StableHash.hs b/src-basis/Moonlight/Core/StableHash.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/StableHash.hs @@ -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) diff --git a/src-basis/Moonlight/Core/TotalRegistry.hs b/src-basis/Moonlight/Core/TotalRegistry.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/TotalRegistry.hs @@ -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 diff --git a/src-basis/Moonlight/Core/TypeLevel.hs b/src-basis/Moonlight/Core/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/TypeLevel.hs @@ -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 diff --git a/src-basis/Moonlight/Core/Validation.hs b/src-basis/Moonlight/Core/Validation.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Core/Validation.hs @@ -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) diff --git a/src-basis/Moonlight/Internal/Unsound.hs b/src-basis/Moonlight/Internal/Unsound.hs new file mode 100644 --- /dev/null +++ b/src-basis/Moonlight/Internal/Unsound.hs @@ -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) diff --git a/src-egraph-program/Moonlight/Core/EGraph/Program.hs b/src-egraph-program/Moonlight/Core/EGraph/Program.hs new file mode 100644 --- /dev/null +++ b/src-egraph-program/Moonlight/Core/EGraph/Program.hs @@ -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 diff --git a/src-numeric/Moonlight/Core/ApproxEq.hs b/src-numeric/Moonlight/Core/ApproxEq.hs new file mode 100644 --- /dev/null +++ b/src-numeric/Moonlight/Core/ApproxEq.hs @@ -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 diff --git a/src-numeric/Moonlight/Core/Canon.hs b/src-numeric/Moonlight/Core/Canon.hs new file mode 100644 --- /dev/null +++ b/src-numeric/Moonlight/Core/Canon.hs @@ -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) diff --git a/src-numeric/Moonlight/Core/CanonicalNumber.hs b/src-numeric/Moonlight/Core/CanonicalNumber.hs new file mode 100644 --- /dev/null +++ b/src-numeric/Moonlight/Core/CanonicalNumber.hs @@ -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, + ) diff --git a/src-numeric/Moonlight/Core/CanonicalNumber/Internal.hs b/src-numeric/Moonlight/Core/CanonicalNumber/Internal.hs new file mode 100644 --- /dev/null +++ b/src-numeric/Moonlight/Core/CanonicalNumber/Internal.hs @@ -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) diff --git a/src-numeric/Moonlight/Core/ExactToken.hs b/src-numeric/Moonlight/Core/ExactToken.hs new file mode 100644 --- /dev/null +++ b/src-numeric/Moonlight/Core/ExactToken.hs @@ -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# #) diff --git a/src-numeric/Moonlight/Core/Niche.hs b/src-numeric/Moonlight/Core/Niche.hs new file mode 100644 --- /dev/null +++ b/src-numeric/Moonlight/Core/Niche.hs @@ -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 + diff --git a/src-numeric/Moonlight/Core/Niche/Internal.hs b/src-numeric/Moonlight/Core/Niche/Internal.hs new file mode 100644 --- /dev/null +++ b/src-numeric/Moonlight/Core/Niche/Internal.hs @@ -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 diff --git a/src-numeric/Moonlight/Core/Numeric.hs b/src-numeric/Moonlight/Core/Numeric.hs new file mode 100644 --- /dev/null +++ b/src-numeric/Moonlight/Core/Numeric.hs @@ -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 diff --git a/src-numeric/Moonlight/Core/Scalar.hs b/src-numeric/Moonlight/Core/Scalar.hs new file mode 100644 --- /dev/null +++ b/src-numeric/Moonlight/Core/Scalar.hs @@ -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) diff --git a/src-numeric/Moonlight/Core/Unsound.hs b/src-numeric/Moonlight/Core/Unsound.hs new file mode 100644 --- /dev/null +++ b/src-numeric/Moonlight/Core/Unsound.hs @@ -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) diff --git a/src-numeric/Moonlight/Internal/FloatMath.hs b/src-numeric/Moonlight/Internal/FloatMath.hs new file mode 100644 --- /dev/null +++ b/src-numeric/Moonlight/Internal/FloatMath.hs @@ -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 + ) diff --git a/src-public/Moonlight/Core.hs b/src-public/Moonlight/Core.hs new file mode 100644 --- /dev/null +++ b/src-public/Moonlight/Core.hs @@ -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 diff --git a/src-solver/Moonlight/Core/Fixpoint.hs b/src-solver/Moonlight/Core/Fixpoint.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint.hs @@ -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, + ) diff --git a/src-solver/Moonlight/Core/Fixpoint/Dense.hs b/src-solver/Moonlight/Core/Fixpoint/Dense.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Dense.hs @@ -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, + ) diff --git a/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/AdaptiveIntSet.hs b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/AdaptiveIntSet.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/AdaptiveIntSet.hs @@ -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 #-} diff --git a/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/ClosureCache.hs b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/ClosureCache.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/ClosureCache.hs @@ -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 #-} diff --git a/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Csr.hs b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Csr.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Csr.hs @@ -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 #-} diff --git a/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Policy.hs b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Policy.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Policy.hs @@ -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 + } diff --git a/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Scc.hs b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Scc.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Scc.hs @@ -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 #-} diff --git a/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Scratch.hs b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Scratch.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Scratch.hs @@ -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 #-} diff --git a/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Snapshot.hs b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Snapshot.hs @@ -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 diff --git a/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Traverse.hs b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Traverse.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Dense/Internal/Traverse.hs @@ -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 #-} diff --git a/src-solver/Moonlight/Core/Fixpoint/Internal/Combinators.hs b/src-solver/Moonlight/Core/Fixpoint/Internal/Combinators.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Internal/Combinators.hs @@ -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) diff --git a/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Arena.hs b/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Arena.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Arena.hs @@ -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) diff --git a/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/BitSet.hs b/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/BitSet.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/BitSet.hs @@ -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 diff --git a/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Engine.hs b/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Engine.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Engine.hs @@ -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 diff --git a/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Plan.hs b/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Plan.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Plan.hs @@ -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) diff --git a/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Types.hs b/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Types.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/Types.hs @@ -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 diff --git a/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/WorkQueue.hs b/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/WorkQueue.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/Fixpoint/Internal/Solver/WorkQueue.hs @@ -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 diff --git a/src-solver/Moonlight/Core/UnionFind.hs b/src-solver/Moonlight/Core/UnionFind.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/UnionFind.hs @@ -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) + } diff --git a/src-solver/Moonlight/Core/UnionFind/Internal/Semantics.hs b/src-solver/Moonlight/Core/UnionFind/Internal/Semantics.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/UnionFind/Internal/Semantics.hs @@ -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 #-} diff --git a/src-solver/Moonlight/Core/UnionFind/Internal/Types.hs b/src-solver/Moonlight/Core/UnionFind/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/UnionFind/Internal/Types.hs @@ -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) diff --git a/src-solver/Moonlight/Core/UnionFind/Transaction.hs b/src-solver/Moonlight/Core/UnionFind/Transaction.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/UnionFind/Transaction.hs @@ -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 diff --git a/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Algorithm.hs b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Algorithm.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Algorithm.hs @@ -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) diff --git a/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/DenseStore.hs b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/DenseStore.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/DenseStore.hs @@ -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 diff --git a/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Lifecycle.hs b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Lifecycle.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Lifecycle.hs @@ -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) diff --git a/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Policy.hs b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Policy.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Policy.hs @@ -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 #-} diff --git a/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Snapshot.hs b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Snapshot.hs @@ -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 diff --git a/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Storage.hs b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Storage.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Storage.hs @@ -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) diff --git a/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Types.hs b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src-solver/Moonlight/Core/UnionFind/Transaction/Internal/Types.hs @@ -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) diff --git a/src-syntax/Moonlight/Core/Fix/Order.hs b/src-syntax/Moonlight/Core/Fix/Order.hs new file mode 100644 --- /dev/null +++ b/src-syntax/Moonlight/Core/Fix/Order.hs @@ -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) diff --git a/src-syntax/Moonlight/Core/Guidance.hs b/src-syntax/Moonlight/Core/Guidance.hs new file mode 100644 --- /dev/null +++ b/src-syntax/Moonlight/Core/Guidance.hs @@ -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) diff --git a/src-syntax/Moonlight/Core/Language.hs b/src-syntax/Moonlight/Core/Language.hs new file mode 100644 --- /dev/null +++ b/src-syntax/Moonlight/Core/Language.hs @@ -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 diff --git a/src-syntax/Moonlight/Core/Pattern.hs b/src-syntax/Moonlight/Core/Pattern.hs new file mode 100644 --- /dev/null +++ b/src-syntax/Moonlight/Core/Pattern.hs @@ -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 diff --git a/src-syntax/Moonlight/Core/Pattern/AntiUnify.hs b/src-syntax/Moonlight/Core/Pattern/AntiUnify.hs new file mode 100644 --- /dev/null +++ b/src-syntax/Moonlight/Core/Pattern/AntiUnify.hs @@ -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 + } diff --git a/src-syntax/Moonlight/Core/Site/Program.hs b/src-syntax/Moonlight/Core/Site/Program.hs new file mode 100644 --- /dev/null +++ b/src-syntax/Moonlight/Core/Site/Program.hs @@ -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) + } diff --git a/src-syntax/Moonlight/Core/Substitution.hs b/src-syntax/Moonlight/Core/Substitution.hs new file mode 100644 --- /dev/null +++ b/src-syntax/Moonlight/Core/Substitution.hs @@ -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] diff --git a/src-syntax/Moonlight/Core/Theory.hs b/src-syntax/Moonlight/Core/Theory.hs new file mode 100644 --- /dev/null +++ b/src-syntax/Moonlight/Core/Theory.hs @@ -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 diff --git a/src-term/Moonlight/Core/Term/Database.hs b/src-term/Moonlight/Core/Term/Database.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database.hs @@ -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 diff --git a/src-term/Moonlight/Core/Term/Database/Arrangement.hs b/src-term/Moonlight/Core/Term/Database/Arrangement.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/Arrangement.hs @@ -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 #-} diff --git a/src-term/Moonlight/Core/Term/Database/Atom.hs b/src-term/Moonlight/Core/Term/Database/Atom.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/Atom.hs @@ -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 #-} diff --git a/src-term/Moonlight/Core/Term/Database/Canonicalize.hs b/src-term/Moonlight/Core/Term/Database/Canonicalize.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/Canonicalize.hs @@ -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 + ] diff --git a/src-term/Moonlight/Core/Term/Database/Command.hs b/src-term/Moonlight/Core/Term/Database/Command.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/Command.hs @@ -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 #-} diff --git a/src-term/Moonlight/Core/Term/Database/Encode.hs b/src-term/Moonlight/Core/Term/Database/Encode.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/Encode.hs @@ -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 #-} diff --git a/src-term/Moonlight/Core/Term/Database/FreeJoin.hs b/src-term/Moonlight/Core/Term/Database/FreeJoin.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/FreeJoin.hs @@ -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 #-} diff --git a/src-term/Moonlight/Core/Term/Database/Index.hs b/src-term/Moonlight/Core/Term/Database/Index.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/Index.hs @@ -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 #-} diff --git a/src-term/Moonlight/Core/Term/Database/Lookup.hs b/src-term/Moonlight/Core/Term/Database/Lookup.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/Lookup.hs @@ -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 #-} diff --git a/src-term/Moonlight/Core/Term/Database/OperatorTable.hs b/src-term/Moonlight/Core/Term/Database/OperatorTable.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/OperatorTable.hs @@ -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 diff --git a/src-term/Moonlight/Core/Term/Database/Pattern.hs b/src-term/Moonlight/Core/Term/Database/Pattern.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/Pattern.hs @@ -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 #-} diff --git a/src-term/Moonlight/Core/Term/Database/Projection.hs b/src-term/Moonlight/Core/Term/Database/Projection.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/Projection.hs @@ -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 #-} diff --git a/src-term/Moonlight/Core/Term/Database/Table.hs b/src-term/Moonlight/Core/Term/Database/Table.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/Table.hs @@ -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 #-} diff --git a/src-term/Moonlight/Core/Term/Database/Transaction.hs b/src-term/Moonlight/Core/Term/Database/Transaction.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/Transaction.hs @@ -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 #-} diff --git a/src-term/Moonlight/Core/Term/Database/Types.hs b/src-term/Moonlight/Core/Term/Database/Types.hs new file mode 100644 --- /dev/null +++ b/src-term/Moonlight/Core/Term/Database/Types.hs @@ -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 #-} diff --git a/test/aggregate/Main.hs b/test/aggregate/Main.hs new file mode 100644 --- /dev/null +++ b/test/aggregate/Main.hs @@ -0,0 +1,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 + ] diff --git a/test/basis/BasisTests.hs b/test/basis/BasisTests.hs new file mode 100644 --- /dev/null +++ b/test/basis/BasisTests.hs @@ -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 + ] diff --git a/test/basis/BoundarySpec.hs b/test/basis/BoundarySpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/BoundarySpec.hs @@ -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 diff --git a/test/basis/CardinalitySpec.hs b/test/basis/CardinalitySpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/CardinalitySpec.hs @@ -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) + ] diff --git a/test/basis/DenseKeySpec.hs b/test/basis/DenseKeySpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/DenseKeySpec.hs @@ -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 diff --git a/test/basis/FiniteSpec.hs b/test/basis/FiniteSpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/FiniteSpec.hs @@ -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) diff --git a/test/basis/IsoNormSpec.hs b/test/basis/IsoNormSpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/IsoNormSpec.hs @@ -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 diff --git a/test/basis/Main.hs b/test/basis/Main.hs new file mode 100644 --- /dev/null +++ b/test/basis/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import qualified BasisTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain BasisTests.tests diff --git a/test/basis/MapAccumSpec.hs b/test/basis/MapAccumSpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/MapAccumSpec.hs @@ -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)])] + ) + ] diff --git a/test/basis/OrdCollectionSpec.hs b/test/basis/OrdCollectionSpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/OrdCollectionSpec.hs @@ -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 diff --git a/test/basis/OrderSpec.hs b/test/basis/OrderSpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/OrderSpec.hs @@ -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 diff --git a/test/basis/ProofManifestSpec.hs b/test/basis/ProofManifestSpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/ProofManifestSpec.hs @@ -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" + ] diff --git a/test/basis/QueueSpec.hs b/test/basis/QueueSpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/QueueSpec.hs @@ -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 diff --git a/test/basis/RelationalSpec.hs b/test/basis/RelationalSpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/RelationalSpec.hs @@ -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 diff --git a/test/basis/StableHashSpec.hs b/test/basis/StableHashSpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/StableHashSpec.hs @@ -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 diff --git a/test/basis/TotalRegistrySpec.hs b/test/basis/TotalRegistrySpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/TotalRegistrySpec.hs @@ -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 diff --git a/test/basis/TypeLevelSpec.hs b/test/basis/TypeLevelSpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/TypeLevelSpec.hs @@ -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 + ] diff --git a/test/basis/ValidationSpec.hs b/test/basis/ValidationSpec.hs new file mode 100644 --- /dev/null +++ b/test/basis/ValidationSpec.hs @@ -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 diff --git a/test/facade/Main.hs b/test/facade/Main.hs new file mode 100644 --- /dev/null +++ b/test/facade/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import qualified PublicSurfaceSpec +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain PublicSurfaceSpec.tests diff --git a/test/facade/PublicSurfaceSpec.hs b/test/facade/PublicSurfaceSpec.hs new file mode 100644 --- /dev/null +++ b/test/facade/PublicSurfaceSpec.hs @@ -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 diff --git a/test/numeric/ApproxEqSpec.hs b/test/numeric/ApproxEqSpec.hs new file mode 100644 --- /dev/null +++ b/test/numeric/ApproxEqSpec.hs @@ -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 + ] + ] diff --git a/test/numeric/CanonSpec.hs b/test/numeric/CanonSpec.hs new file mode 100644 --- /dev/null +++ b/test/numeric/CanonSpec.hs @@ -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 + ] + ] diff --git a/test/numeric/CanonicalNumberSpec.hs b/test/numeric/CanonicalNumberSpec.hs new file mode 100644 --- /dev/null +++ b/test/numeric/CanonicalNumberSpec.hs @@ -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) + ] + ] diff --git a/test/numeric/ExactTokenSpec.hs b/test/numeric/ExactTokenSpec.hs new file mode 100644 --- /dev/null +++ b/test/numeric/ExactTokenSpec.hs @@ -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) + ] diff --git a/test/numeric/Main.hs b/test/numeric/Main.hs new file mode 100644 --- /dev/null +++ b/test/numeric/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import qualified NumericTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain NumericTests.tests diff --git a/test/numeric/NicheSpec.hs b/test/numeric/NicheSpec.hs new file mode 100644 --- /dev/null +++ b/test/numeric/NicheSpec.hs @@ -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) diff --git a/test/numeric/NumericTests.hs b/test/numeric/NumericTests.hs new file mode 100644 --- /dev/null +++ b/test/numeric/NumericTests.hs @@ -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 + ] diff --git a/test/numeric/ScalarLawsSpec.hs b/test/numeric/ScalarLawsSpec.hs new file mode 100644 --- /dev/null +++ b/test/numeric/ScalarLawsSpec.hs @@ -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 diff --git a/test/solver/FixpointSpec.hs b/test/solver/FixpointSpec.hs new file mode 100644 --- /dev/null +++ b/test/solver/FixpointSpec.hs @@ -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) diff --git a/test/solver/Main.hs b/test/solver/Main.hs new file mode 100644 --- /dev/null +++ b/test/solver/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import qualified SolverTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain SolverTests.tests diff --git a/test/solver/SolverTests.hs b/test/solver/SolverTests.hs new file mode 100644 --- /dev/null +++ b/test/solver/SolverTests.hs @@ -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 + ] diff --git a/test/solver/UnionFindSpec.hs b/test/solver/UnionFindSpec.hs new file mode 100644 --- /dev/null +++ b/test/solver/UnionFindSpec.hs @@ -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 diff --git a/test/support/LawProperty.hs b/test/support/LawProperty.hs new file mode 100644 --- /dev/null +++ b/test/support/LawProperty.hs @@ -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) diff --git a/test/support/SourceShape.hs b/test/support/SourceShape.hs new file mode 100644 --- /dev/null +++ b/test/support/SourceShape.hs @@ -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)) diff --git a/test/syntax/Main.hs b/test/syntax/Main.hs new file mode 100644 --- /dev/null +++ b/test/syntax/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import qualified SyntaxTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain SyntaxTests.tests diff --git a/test/syntax/PatternSpec.hs b/test/syntax/PatternSpec.hs new file mode 100644 --- /dev/null +++ b/test/syntax/PatternSpec.hs @@ -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 + ] diff --git a/test/syntax/SubstitutionSpec.hs b/test/syntax/SubstitutionSpec.hs new file mode 100644 --- /dev/null +++ b/test/syntax/SubstitutionSpec.hs @@ -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 diff --git a/test/syntax/SyntaxTests.hs b/test/syntax/SyntaxTests.hs new file mode 100644 --- /dev/null +++ b/test/syntax/SyntaxTests.hs @@ -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 + ] diff --git a/test/syntax/TheorySpec.hs b/test/syntax/TheorySpec.hs new file mode 100644 --- /dev/null +++ b/test/syntax/TheorySpec.hs @@ -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) diff --git a/test/term/DatabaseLawSpec.hs b/test/term/DatabaseLawSpec.hs new file mode 100644 --- /dev/null +++ b/test/term/DatabaseLawSpec.hs @@ -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) + <> "}" diff --git a/test/term/DatabaseSpec.hs b/test/term/DatabaseSpec.hs new file mode 100644 --- /dev/null +++ b/test/term/DatabaseSpec.hs @@ -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 diff --git a/test/term/Main.hs b/test/term/Main.hs new file mode 100644 --- /dev/null +++ b/test/term/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import qualified TermTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain TermTests.tests diff --git a/test/term/TermTests.hs b/test/term/TermTests.hs new file mode 100644 --- /dev/null +++ b/test/term/TermTests.hs @@ -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 + ]