diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,24 @@ +# Changelog + +All notable changes to `moonlight-pale` are documented here. + +## 0.1.0.0 - 2026-07-22 + +Initial release of Moonlight's shared diagnostics, law-testing, and source-reading +package. Depends up onto `moonlight-core` only. + +Seven public sublibraries; depend on the smallest slice you use. + +- `diagnostic` — severity and the accumulating `Diagnosed` writer, plus boundary, + homotopy, cohomology, local-run, aggregation, summary, and derived-view vocabulary. + Pure `base` + `containers`. +- `test` — assertions, fixtures, runners, resource paths, and a bounded-recursion bridge. +- `test-surface` — import-discipline checks over the public layering. +- `test-laws` — algebraic law predicates and the `LawSuite` DSL. +- `ghc-surface` — a scoped, normalized expression algebra with structural equivalence + and faithful rendering; `.hie` reading, source-key indexing, a type-word oracle; and a + module-surface summary. The only sublibrary that speaks `ghc`. +- `diagnostic-ghc` — compile-diagnostic snapshot capture. +- `measurement` — checked RTS-cost sampling for benchmark executables. + +Each sublibrary carries its own test-suite. Builds clean under `-Wall -Wcompat`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Blue Rose + +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,37 @@ +# moonlight-pale + +> Part of **Moonlight**, the sheaf-theoretic computation layer beneath +> [Melusine](https://bluerose.blue) and Pale Meridian. + +`moonlight-pale` centralizes diagnostics, law testing, and GHC/HIE tooling without +forcing `ghc` on Moonlight's foundation packages. + +It ships as a family of single-role public sublibraries; depend on the smallest +slice you use. Modules live under `Moonlight.Pale.*`. This README owns package-level +narrative; Haddock adds only terse module summaries, never repetitive per-export prose. + +## Surface & boundaries + +| Cabal dependency | Front-door import | What you get | +| --- | --- | --- | +| `moonlight-pale:diagnostic` | `Moonlight.Pale.Diagnostic.Core` | Severities and the accumulating `Diagnosed` writer; topology, local-run, aggregation, summary, and derived-view vocabulary; replay statistics in validated refinement types. Pure `base` + `containers`. | +| `moonlight-pale:test` | `Moonlight.Pale.Test.Core` | Validated tolerances, shared budgets, typed assertions, resource discovery, and recursion-coherence predicates. | +| `moonlight-pale:test-surface` | `Moonlight.Pale.Test.ImportDiscipline` | Import-discipline checks over the public layering. | +| `moonlight-pale:test-laws` | `Moonlight.Pale.Test.Laws.Suite` | Algebraic law predicates (`Semigroup`, `Monoid`, lattice, restriction) and the `LawSuite` DSL that names each law it checks. | +| `moonlight-pale:ghc-surface` | `Moonlight.Pale.Ghc.Expr`, `.Hie.Read`, `.ModuleSurface` | A scoped, normalized expression algebra with structural equivalence and faithful rendering; `.hie` reading, source-key indexing, a type-word oracle; and a module-surface summary. The only sublibrary that speaks `ghc`. | +| `moonlight-pale:diagnostic-ghc` | `Moonlight.Pale.TestSupport.CompileDiagnostics` | Compile-diagnostic snapshot capture: drives the compiler as a subprocess and serializes diagnostics for tests. | +| `moonlight-pale:measurement` | `Moonlight.Pale.Bench.Measure` | Checked, process-scoped RTS-cost sampling for benchmark executables that need an explicit allocation receipt. Microbenchmarks use `tasty-bench` directly. | + +`moonlight-pale` depends up onto `moonlight-core` only; it never depends on a +higher foundation package, so it introduces no cycle. The `diagnostic` sublibrary +pays for nothing but `base` + `containers`; only `ghc-surface` pulls `ghc`. + +## Test + +```bash +cabal test moonlight-pale +``` + +## License + +MIT. See [`LICENSE`](./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,37 @@ +module Main + ( main, + ) +where + +import DiagnosticBench (diagnosticBenchmarks) +import GhcSurfaceBench (ghcSurfaceBenchmarks) +import HieBench (hieBenchmarks) +import LawBench (lawBenchmarks) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + case (ghcSurfaceBenchmarks, hieBenchmarks, lawBenchmarks) of + (Left obstruction, _, _) -> + rejectBenchmarkCorpus "GHC surface" obstruction + (_, Left obstruction, _) -> + rejectBenchmarkCorpus "HIE type graph" obstruction + (_, _, Left obstruction) -> + rejectBenchmarkCorpus "finite laws" obstruction + ( Right surfaceBenchmarks, + Right hieTypeBenchmarks, + Right finiteLawBenchmarks + ) -> + defaultMain + [ diagnosticBenchmarks, + surfaceBenchmarks, + hieTypeBenchmarks, + finiteLawBenchmarks + ] + +rejectBenchmarkCorpus :: Show obstruction => String -> obstruction -> IO () +rejectBenchmarkCorpus corpusLabel obstruction = do + hPutStrLn stderr ("moonlight-pale " <> corpusLabel <> " benchmark corpus rejected: " <> show obstruction) + exitFailure diff --git a/bench/diagnostic/DiagnosticBench.hs b/bench/diagnostic/DiagnosticBench.hs new file mode 100644 --- /dev/null +++ b/bench/diagnostic/DiagnosticBench.hs @@ -0,0 +1,387 @@ +-- @moonlight-pale:diagnostic@ workloads over deterministic repeated- and +-- distinct-cardinality mismatch corpora. Every result is reduced through the +-- full ordered payload; a cheap length masquerading as semantic work is not a +-- benchmark. +module DiagnosticBench + ( RestrictionCorpus, + RestrictionDigest (..), + repeatedRestrictionCorpus, + distinctRestrictionCorpus, + outcomeSummaryMconcat, + outcomeSummaryLeftFold, + outcomeSummaryBalanced, + restrictionIndexStatsDigest, + restrictionHotspotDigest, + diagnosticBenchmarks, + ) +where + +import BenchSupport (preparedBenchmarks) +import Control.DeepSeq (NFData (rnf)) +import Data.List (sortOn) +import Data.Ord (Down (..)) +import Moonlight.Pale.Diagnostic.Aggregation.Algebra + ( OutcomeSummary, + RestrictionIndex, + outcomeSummaryFromRestrictionOutcome, + outcomeSummaryRestrictionOutcomes, + restrictionIndexFromOutcomes, + restrictionIndexStats, + restrictionIndexTotal, + topRestrictionHotspots, + ) +import Moonlight.Pale.Diagnostic.Local.Propagation + ( RestrictionOutcomeStat + ( rosMismatch, + rosOccurrences, + rosSourceCell, + rosTargetCell + ), + RestrictionRunOutcome (RestrictionMismatch), + ) +import Test.Tasty.Bench (Benchmark, bgroup) + +diagnosticBenchmarks :: Benchmark +diagnosticBenchmarks = + bgroup + "diagnostic" + ( fmap + (\(regimeLabel, corpusFromSize) -> regimeBenchmarks regimeLabel corpusFromSize) + restrictionRegimes + <> [ bgroup + "cardinality-matrix" + [ bgroup + "cell-cardinality" + ( preparedBenchmarks + "cells" + cellCardinalityCorpora + restrictionIndexStatsDigest + ), + bgroup + "mismatch-cardinality" + ( preparedBenchmarks + "mismatches" + mismatchCardinalityCorpora + restrictionIndexStatsDigest + ) + ], + bgroup + "hotspot-k" + (fmap (uncurry hotspotCardinalityBenchmarks) hotspotIndexScales) + ] + ) + +regimeBenchmarks :: String -> (Int -> RestrictionCorpus) -> Benchmark +regimeBenchmarks regimeLabel corpusFromSize = + bgroup + regimeLabel + [ bgroup + "outcome-summary-mconcat" + (preparedBenchmarks "restrictions" preparedCorpora outcomeSummaryMconcat), + bgroup + "outcome-summary-left-fold" + (preparedBenchmarks "restrictions" preparedCorpora outcomeSummaryLeftFold), + bgroup + "outcome-summary-balanced" + (preparedBenchmarks "restrictions" preparedCorpora outcomeSummaryBalanced), + bgroup + "restriction-index-stats" + (preparedBenchmarks "restrictions" preparedCorpora restrictionIndexStatsDigest), + bgroup + "restriction-hotspots-top-16" + (preparedBenchmarks "restrictions" preparedCorpora restrictionHotspotDigest) + ] + where + preparedCorpora = + fmap (\size -> (size, corpusFromSize size)) restrictionSizes + +restrictionSizes :: [Int] +restrictionSizes = + [256, 2048, 16384] + +restrictionRegimes :: [(String, Int -> RestrictionCorpus)] +restrictionRegimes = + [ ("repeated-cardinality", repeatedRestrictionCorpus), + ("distinct-cardinality", distinctRestrictionCorpus) + ] + +fixedCardinalityAtomCount :: Int +fixedCardinalityAtomCount = + 16384 + +cellCardinalityCorpora :: [(Int, RestrictionCorpus)] +cellCardinalityCorpora = + fmap + ( \cellCardinality -> + ( cellCardinality, + cardinalityRestrictionCorpus + fixedCardinalityAtomCount + cellCardinality + 8 + ) + ) + [16, 64, 256] + +mismatchCardinalityCorpora :: [(Int, RestrictionCorpus)] +mismatchCardinalityCorpora = + fmap + ( \mismatchCardinality -> + ( mismatchCardinality, + cardinalityRestrictionCorpus + fixedCardinalityAtomCount + 64 + mismatchCardinality + ) + ) + [2, 16, 128] + +hotspotIndexScales :: [(Int, [Int])] +hotspotIndexScales = + [ (2048, [1, 16, 45, 1023, 1024, 2048]), + (16384, [1, 16, 128, 8191, 8192, 16384]), + (65536, [1, 16, 256, 32767, 32768, 65536]) + ] + +hotspotCardinalityBenchmarks :: Int -> [Int] -> Benchmark +hotspotCardinalityBenchmarks uniqueAtomCount hotspotCounts = + let preparedCorpora = hotspotKCorpora uniqueAtomCount hotspotCounts + in bgroup + ("unique-atoms/" <> show uniqueAtomCount) + [ bgroup + "production-hybrid" + ( preparedBenchmarks + "k" + preparedCorpora + restrictionPreparedHotspotDigest + ), + bgroup + "full-sort-reference" + ( preparedBenchmarks + "k" + preparedCorpora + restrictionPreparedFullSortDigest + ) + ] + +hotspotKCorpora :: Int -> [Int] -> [(Int, RestrictionHotspotCase)] +hotspotKCorpora uniqueAtomCount hotspotCounts = + let restrictionIndex = + restrictionIndexFromOutcomes + (restrictionCorpusOutcomes (rankedRestrictionCorpus uniqueAtomCount)) + in fmap + ( \hotspotCount -> + ( hotspotCount, + RestrictionHotspotCase + { restrictionHotspotCount = hotspotCount, + restrictionHotspotIndex = restrictionIndex + } + ) + ) + hotspotCounts + +newtype RestrictionCorpus = RestrictionCorpus + { restrictionCorpusOutcomes :: [RestrictionRunOutcome Int Int] + } + +instance NFData RestrictionCorpus where + rnf = + foldr + (\outcome forcedTail -> forceRestrictionOutcome outcome `seq` forcedTail) + () + . restrictionCorpusOutcomes + +data RestrictionHotspotCase = RestrictionHotspotCase + { restrictionHotspotCount :: !Int, + restrictionHotspotIndex :: !(RestrictionIndex Int Int) + } + +instance NFData RestrictionHotspotCase where + rnf hotspotCase = + rnf (restrictionHotspotCount hotspotCase) + `seq` forceRestrictionIndex (restrictionHotspotIndex hotspotCase) + +data RestrictionDigest = RestrictionDigest + { restrictionDigestValues :: !Int, + restrictionDigestHash :: !Int + } + deriving stock (Eq, Show) + +instance NFData RestrictionDigest where + rnf (RestrictionDigest valueCount hashValue) = + rnf valueCount `seq` rnf hashValue + +forceRestrictionOutcome :: RestrictionRunOutcome Int Int -> () +forceRestrictionOutcome (RestrictionMismatch sourceCell targetCell mismatches) = + rnf sourceCell `seq` rnf targetCell `seq` rnf mismatches + +forceRestrictionIndex :: RestrictionIndex Int Int -> () +forceRestrictionIndex restrictionIndex = + foldr + (\statValue forcedTail -> forceRestrictionStat statValue `seq` forcedTail) + (rnf (restrictionIndexTotal restrictionIndex)) + (restrictionIndexStats restrictionIndex) + +forceRestrictionStat :: RestrictionOutcomeStat Int Int -> () +forceRestrictionStat statValue = + rnf (rosSourceCell statValue) + `seq` rnf (rosTargetCell statValue) + `seq` rnf (rosMismatch statValue) + `seq` rnf (rosOccurrences statValue) + +repeatedRestrictionCorpus :: Int -> RestrictionCorpus +repeatedRestrictionCorpus count = + RestrictionCorpus + [ RestrictionMismatch (index `mod` 64) ((index + 1) `mod` 64) [index `mod` 8] + | index <- [1 .. count] + ] + +distinctRestrictionCorpus :: Int -> RestrictionCorpus +distinctRestrictionCorpus count = + RestrictionCorpus + [ RestrictionMismatch index (index + 1) [index] + | index <- [1 .. count] + ] + +rankedRestrictionCorpus :: Int -> RestrictionCorpus +rankedRestrictionCorpus count = + RestrictionCorpus + [ RestrictionMismatch + index + (index + 1) + (replicate (1 + (index `mod` 7)) index) + | index <- [1 .. count] + ] + +cardinalityRestrictionCorpus :: Int -> Int -> Int -> RestrictionCorpus +cardinalityRestrictionCorpus atomCount cellCardinality mismatchCardinality = + RestrictionCorpus + [ RestrictionMismatch + (index `mod` cellCardinality) + ((index + 1) `mod` cellCardinality) + [index `mod` mismatchCardinality] + | index <- [1 .. atomCount] + ] + +outcomeSummaryMconcat :: RestrictionCorpus -> RestrictionDigest +outcomeSummaryMconcat corpus = + outcomeSummaryDigest + (mconcat (fmap liftRestrictionOutcome (restrictionCorpusOutcomes corpus))) + +outcomeSummaryLeftFold :: RestrictionCorpus -> RestrictionDigest +outcomeSummaryLeftFold corpus = + outcomeSummaryDigest + (foldl' (<>) mempty (fmap liftRestrictionOutcome (restrictionCorpusOutcomes corpus))) + +outcomeSummaryBalanced :: RestrictionCorpus -> RestrictionDigest +outcomeSummaryBalanced corpus = + outcomeSummaryDigest + ( balancedSummary + (fmap liftRestrictionOutcome (restrictionCorpusOutcomes corpus)) + ) + +balancedSummary :: [OutcomeSummary Int Int () () () ()] -> OutcomeSummary Int Int () () () () +balancedSummary = \case + [] -> + mempty + [summaryValue] -> + summaryValue + summaryValues -> + balancedSummary (pairAdjacentSummaries summaryValues) + +pairAdjacentSummaries :: + [OutcomeSummary Int Int () () () ()] -> + [OutcomeSummary Int Int () () () ()] +pairAdjacentSummaries = \case + [] -> + [] + [summaryValue] -> + [summaryValue] + leftSummary : rightSummary : remainingSummaries -> + (leftSummary <> rightSummary) : pairAdjacentSummaries remainingSummaries + +liftRestrictionOutcome :: + RestrictionRunOutcome Int Int -> + OutcomeSummary Int Int () () () () +liftRestrictionOutcome = + outcomeSummaryFromRestrictionOutcome + +outcomeSummaryDigest :: OutcomeSummary Int Int () () () () -> RestrictionDigest +outcomeSummaryDigest = + foldl' restrictionOutcomeDigest emptyRestrictionDigest + . outcomeSummaryRestrictionOutcomes + +restrictionIndexStatsDigest :: RestrictionCorpus -> RestrictionDigest +restrictionIndexStatsDigest corpus = + let restrictionIndex = + restrictionIndexFromOutcomes (restrictionCorpusOutcomes corpus) + in digestInt + (foldl' restrictionStatDigest emptyRestrictionDigest (restrictionIndexStats restrictionIndex)) + (restrictionIndexTotal restrictionIndex) + +restrictionHotspotDigest :: RestrictionCorpus -> RestrictionDigest +restrictionHotspotDigest corpus = + restrictionHotspotDigestFor 16 corpus + +restrictionHotspotDigestFor :: Int -> RestrictionCorpus -> RestrictionDigest +restrictionHotspotDigestFor hotspotCount corpus = + foldl' + restrictionStatDigest + emptyRestrictionDigest + ( topRestrictionHotspots + hotspotCount + (restrictionIndexFromOutcomes (restrictionCorpusOutcomes corpus)) + ) + +restrictionPreparedHotspotDigest :: RestrictionHotspotCase -> RestrictionDigest +restrictionPreparedHotspotDigest hotspotCase = + foldl' + restrictionStatDigest + emptyRestrictionDigest + ( topRestrictionHotspots + (restrictionHotspotCount hotspotCase) + (restrictionHotspotIndex hotspotCase) + ) + +restrictionPreparedFullSortDigest :: RestrictionHotspotCase -> RestrictionDigest +restrictionPreparedFullSortDigest hotspotCase = + foldl' + restrictionStatDigest + emptyRestrictionDigest + ( take + (restrictionHotspotCount hotspotCase) + ( sortOn + (Down . rosOccurrences) + (restrictionIndexStats (restrictionHotspotIndex hotspotCase)) + ) + ) + +restrictionOutcomeDigest :: RestrictionDigest -> RestrictionRunOutcome Int Int -> RestrictionDigest +restrictionOutcomeDigest digest (RestrictionMismatch sourceCell targetCell mismatches) = + foldl' + digestInt + (digestInt (digestInt digest sourceCell) targetCell) + mismatches + +restrictionStatDigest :: RestrictionDigest -> RestrictionOutcomeStat Int Int -> RestrictionDigest +restrictionStatDigest digest stat = + digestInt + ( digestInt + (digestInt (digestInt digest (rosSourceCell stat)) (rosTargetCell stat)) + (rosMismatch stat) + ) + (rosOccurrences stat) + +emptyRestrictionDigest :: RestrictionDigest +emptyRestrictionDigest = + RestrictionDigest + { restrictionDigestValues = 0, + restrictionDigestHash = 2166136261 + } + +digestInt :: RestrictionDigest -> Int -> RestrictionDigest +digestInt digest value = + RestrictionDigest + { restrictionDigestValues = restrictionDigestValues digest + 1, + restrictionDigestHash = + (restrictionDigestHash digest * 16777619) + value + } diff --git a/bench/diagnostic/Main.hs b/bench/diagnostic/Main.hs new file mode 100644 --- /dev/null +++ b/bench/diagnostic/Main.hs @@ -0,0 +1,10 @@ +module Main + ( main, + ) +where + +import DiagnosticBench (diagnosticBenchmarks) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = defaultMain [diagnosticBenchmarks] diff --git a/bench/ghc-surface/GhcSurfaceBench.hs b/bench/ghc-surface/GhcSurfaceBench.hs new file mode 100644 --- /dev/null +++ b/bench/ghc-surface/GhcSurfaceBench.hs @@ -0,0 +1,685 @@ +-- Parse-and-convert workloads for @moonlight-pale:ghc-surface@. The +-- common-subset corpus is deliberately restricted to syntax shared with the +-- historical converter; the full-fidelity corpus exercises current structural +-- ownership and is therefore not offered as a historical ratio gate. +module GhcSurfaceBench + ( GhcSurfaceBenchmarkObstruction (..), + SemanticConversionManifest (..), + ConversionBenchmarkDigest, + PreparedConversionCorpus, + commonSubsetSemanticManifests, + commonSubsetWorkload, + prepareCommonSubsetCorpus, + convertCommonCorpus, + conversionBenchmarkDigestHash, + ghcSurfaceBenchmarks, + ) +where + +import BenchSupport (preparedBenchmarks) +import Control.DeepSeq (NFData (rnf)) +import Data.Bifunctor (first) +import Data.Foldable (toList) +import Data.List (intercalate) +import Data.Text qualified as Text +import Moonlight.Core (binderIdKey) +import Moonlight.Pale.Ghc.Expr + ( BinderAnn (..), + Binding (..), + BindingGroup, + Clause (..), + ConvertedModule (..), + ConvertedModuleMetrics + ( cmmBindingCount, + cmmGlobalVarRefCount, + cmmLambdaSiteCount, + cmmLetSiteCount, + cmmLocalVarRefCount, + cmmMaxFreeScopeCount, + cmmObservedContextCount, + cmmScopedExprCount + ), + ConvertObstruction, + Expr, + LayoutPolicy (CompactLayout), + ModuleRenderContext (..), + RenderRefusal, + RenderTarget (RenderConvertedModule), + Rhs (..), + ScopeCtx (..), + ScopeLookupFailure, + SourceRegion (..), + ConvertedValueBinding, + bindingGroupBindings, + bindingGroupScope, + bindingNames, + convertHaskellSource, + convertedModuleBindings, + convertedModuleMetrics, + exprFreeScopes, + exprNode, + exprRegion, + exprScope, + freeScopeSummaryToList, + renderSource, + renderRdrName, + scopeIdKey, + scopeObservedContexts, + tlbBinding, + tlbRegion, + tlbScope, + ) +import Test.Tasty.Bench (Benchmark, bgroup) + +data GhcSurfaceBenchmarkObstruction + = InvalidCommonSubsetSize !Int + | BenchmarkConversionRejected !String !ConvertObstruction + | BenchmarkRenderingRefused !String !RenderRefusal + | BenchmarkScopeMetadataRejected !String !ScopeLookupFailure + | UnexpectedBindingCardinality !String !Int !Int + | UnexpectedBindingNameCardinality !String ![String] + | UnexpectedOrderedBinders !String ![String] ![String] + deriving stock (Eq, Show) + +instance NFData GhcSurfaceBenchmarkObstruction where + rnf obstruction = + rnf (show obstruction) + +-- The overlap section used to glue current and historical conversion rows. +-- It is semantic source plus ordered top-level binder evidence, not internal +-- structural node counts whose owners deliberately changed in the rewrite. +data SemanticConversionManifest = SemanticConversionManifest + { semanticManifestBindingCount :: !Int, + semanticManifestRenderedModule :: !String, + semanticManifestOrderedBinders :: ![String] + } + deriving stock (Eq, Show) + +instance NFData SemanticConversionManifest where + rnf manifest = + rnf (semanticManifestBindingCount manifest) + `seq` rnf (semanticManifestRenderedModule manifest) + `seq` rnf (semanticManifestOrderedBinders manifest) + +-- Current-only readiness evidence. All eight metrics are forced and retained +-- for performance accounting, but are not cross-version equality evidence. +data RepresentationReadinessDigest = RepresentationReadinessDigest + { readinessBindingCount :: !Int, + readinessObservedContextCount :: !Int, + readinessLambdaSiteCount :: !Int, + readinessLetSiteCount :: !Int, + readinessScopedExprCount :: !Int, + readinessGlobalVarRefCount :: !Int, + readinessLocalVarRefCount :: !Int, + readinessMaxFreeScopeCount :: !Int, + readinessAnnotationDigest :: !Int + } + deriving stock (Eq, Show) + +instance NFData RepresentationReadinessDigest where + rnf digest = + rnf (readinessBindingCount digest) + `seq` rnf (readinessObservedContextCount digest) + `seq` rnf (readinessLambdaSiteCount digest) + `seq` rnf (readinessLetSiteCount digest) + `seq` rnf (readinessScopedExprCount digest) + `seq` rnf (readinessGlobalVarRefCount digest) + `seq` rnf (readinessLocalVarRefCount digest) + `seq` rnf (readinessMaxFreeScopeCount digest) + `seq` rnf (readinessAnnotationDigest digest) + +data ConversionBenchmarkDigest = ConversionBenchmarkDigest + { conversionSemanticManifest :: !SemanticConversionManifest, + conversionRepresentationReadiness :: !RepresentationReadinessDigest + } + deriving stock (Eq, Show) + +instance NFData ConversionBenchmarkDigest where + rnf digest = + rnf (conversionSemanticManifest digest) + `seq` rnf (conversionRepresentationReadiness digest) + +conversionBenchmarkDigestHash :: ConversionBenchmarkDigest -> Int +conversionBenchmarkDigestHash digest = + let semanticManifest = conversionSemanticManifest digest + readinessDigest = conversionRepresentationReadiness digest + semanticHash = + foldl' + digestString + (digestInt 2166136261 (semanticManifestBindingCount semanticManifest)) + ( semanticManifestRenderedModule semanticManifest + : semanticManifestOrderedBinders semanticManifest + ) + in foldl' + digestInt + semanticHash + [ readinessBindingCount readinessDigest, + readinessObservedContextCount readinessDigest, + readinessLambdaSiteCount readinessDigest, + readinessLetSiteCount readinessDigest, + readinessScopedExprCount readinessDigest, + readinessGlobalVarRefCount readinessDigest, + readinessLocalVarRefCount readinessDigest, + readinessMaxFreeScopeCount readinessDigest, + readinessAnnotationDigest readinessDigest + ] + +data PreparedConversionCorpus = PreparedConversionCorpus + { preparedCorpusLabel :: !String, + preparedCorpusSource :: !String + } + deriving stock (Eq, Show) + +instance NFData PreparedConversionCorpus where + rnf corpus = + rnf (preparedCorpusLabel corpus) + `seq` rnf (preparedCorpusSource corpus) + +ghcSurfaceBenchmarks :: Either GhcSurfaceBenchmarkObstruction Benchmark +ghcSurfaceBenchmarks = do + commonCorpora <- traverse prepareCommonSubsetCorpus commonSubsetSizes + fullFidelityCorpus <- prepareFullFidelityCorpus + structuralBenchmarks <- traverse prepareStructuralBenchmark structuralCorpusFamilies + pure + ( bgroup + "ghc-surface" + [ bgroup + "common-subset-convert-and-normalize" + (preparedBenchmarks "bindings" commonCorpora convertCommonCorpus), + bgroup + "current-full-fidelity" + (preparedBenchmarks "modules" [(1, fullFidelityCorpus)] convertFullFidelityCorpus), + bgroup + "current-structure-matrix" + structuralBenchmarks + ] + ) + +prepareStructuralBenchmark :: + (String, [Int], Int -> String) -> + Either GhcSurfaceBenchmarkObstruction Benchmark +prepareStructuralBenchmark (familyLabel, sizes, sourceForSize) = do + preparedCorpora <- + traverse + ( \size -> + prepareStructuralCorpus + familyLabel + size + (sourceForSize size) + ) + sizes + pure + ( bgroup + familyLabel + (preparedBenchmarks "size" preparedCorpora convertFullFidelityCorpus) + ) + +prepareStructuralCorpus :: + String -> + Int -> + String -> + Either GhcSurfaceBenchmarkObstruction (Int, PreparedConversionCorpus) +prepareStructuralCorpus familyLabel size sourceText = do + let corpus = + PreparedConversionCorpus + { preparedCorpusLabel = familyLabel <> "/" <> show size, + preparedCorpusSource = sourceText + } + _ <- convertFullFidelityCorpus corpus + pure (size, corpus) + +structuralCorpusFamilies :: [(String, [Int], Int -> String)] +structuralCorpusFamilies = + [ ("scope-depth", [8, 32, 128], scopeDepthModule), + ("scope-branch-count", [8, 32, 128], scopeBranchModule), + ("shadow-depth", [8, 32, 128], shadowDepthModule), + ("sparse-scc-cardinality", [8, 32, 128], sparseSccModule), + ("dense-scc-cardinality", [4, 8, 16], denseSccModule), + ("rendered-list-elements", [32, 256, 2048], renderedListModule), + ("opaque-declaration-position", [0, 32, 128], opaqueDeclarationPositionModule) + ] + +commonSubsetSemanticManifests :: Either GhcSurfaceBenchmarkObstruction [(Int, SemanticConversionManifest)] +commonSubsetSemanticManifests = + traverse + ( \bindingCount -> + fmap + ((,) bindingCount . conversionSemanticManifest) + (commonSubsetWorkload bindingCount) + ) + commonSubsetSizes + +commonSubsetWorkload :: Int -> Either GhcSurfaceBenchmarkObstruction ConversionBenchmarkDigest +commonSubsetWorkload bindingCount + | bindingCount <= 0 = + Left (InvalidCommonSubsetSize bindingCount) + | otherwise = do + let corpus = commonSubsetCorpus bindingCount + expectedBinders = fmap (\index -> "f" <> show index) [1 .. bindingCount] + digest <- convertCommonCorpus corpus + validateCommonDigest + (preparedCorpusLabel corpus) + bindingCount + expectedBinders + digest + pure digest + +commonSubsetSizes :: [Int] +commonSubsetSizes = + [8, 32, 128] + +prepareCommonSubsetCorpus :: Int -> Either GhcSurfaceBenchmarkObstruction (Int, PreparedConversionCorpus) +prepareCommonSubsetCorpus bindingCount = + (bindingCount, commonSubsetCorpus bindingCount) + <$ commonSubsetWorkload bindingCount + +commonSubsetCorpus :: Int -> PreparedConversionCorpus +commonSubsetCorpus bindingCount = + PreparedConversionCorpus + { preparedCorpusLabel = "common-subset/" <> show bindingCount, + preparedCorpusSource = commonSubsetModule bindingCount + } + +prepareFullFidelityCorpus :: Either GhcSurfaceBenchmarkObstruction PreparedConversionCorpus +prepareFullFidelityCorpus = do + let corpus = + PreparedConversionCorpus + { preparedCorpusLabel = "current-full-fidelity", + preparedCorpusSource = fullFidelityModule + } + _ <- convertFullFidelityCorpus corpus + pure corpus + +convertCommonCorpus :: PreparedConversionCorpus -> Either GhcSurfaceBenchmarkObstruction ConversionBenchmarkDigest +convertCommonCorpus corpus = do + convertedModule <- convertCorpus corpus + semanticManifest <- commonSemanticManifest (preparedCorpusLabel corpus) convertedModule + readinessDigest <- representationReadinessDigest (preparedCorpusLabel corpus) convertedModule + pure + ConversionBenchmarkDigest + { conversionSemanticManifest = semanticManifest, + conversionRepresentationReadiness = readinessDigest + } + +convertFullFidelityCorpus :: PreparedConversionCorpus -> Either GhcSurfaceBenchmarkObstruction ConversionBenchmarkDigest +convertFullFidelityCorpus corpus = do + convertedModule <- convertCorpus corpus + renderedModule <- + first + (BenchmarkRenderingRefused (preparedCorpusLabel corpus)) + ( Text.unpack + <$> renderSource + CompactLayout + ( RenderConvertedModule + (ModuleRenderContext "" (Just "Bench")) + convertedModule + ) + ) + let metrics = convertedModuleMetrics convertedModule + let orderedBinders = orderedBindingNames convertedModule + readinessDigest <- representationReadinessDigest (preparedCorpusLabel corpus) convertedModule + pure + ConversionBenchmarkDigest + { conversionSemanticManifest = + SemanticConversionManifest + { semanticManifestBindingCount = cmmBindingCount metrics, + semanticManifestRenderedModule = renderedModule, + semanticManifestOrderedBinders = orderedBinders + }, + conversionRepresentationReadiness = readinessDigest + } + +convertCorpus :: PreparedConversionCorpus -> Either GhcSurfaceBenchmarkObstruction ConvertedModule +convertCorpus corpus = + case convertHaskellSource "Bench.hs" (preparedCorpusSource corpus) of + Left obstruction -> + Left (BenchmarkConversionRejected (preparedCorpusLabel corpus) obstruction) + Right convertedModule -> + Right convertedModule + +commonSemanticManifest :: + String -> + ConvertedModule -> + Either GhcSurfaceBenchmarkObstruction SemanticConversionManifest +commonSemanticManifest corpusLabel convertedModule = do + orderedBinders <- + traverse + (commonBindingName corpusLabel) + (convertedModuleBindings convertedModule) + renderedModule <- + first + (BenchmarkRenderingRefused corpusLabel) + ( Text.unpack + <$> renderSource + CompactLayout + ( RenderConvertedModule + (ModuleRenderContext "" (Just "Bench")) + convertedModule + ) + ) + pure + SemanticConversionManifest + { semanticManifestBindingCount = length orderedBinders, + semanticManifestRenderedModule = renderedModule, + semanticManifestOrderedBinders = orderedBinders + } + +commonBindingName :: + String -> + ConvertedValueBinding -> + Either GhcSurfaceBenchmarkObstruction String +commonBindingName corpusLabel topLevelBinding = + case fmap renderRdrName (bindingNames (tlbBinding topLevelBinding)) of + [bindingName] -> + Right bindingName + names -> + Left (UnexpectedBindingNameCardinality corpusLabel names) + +validateCommonDigest :: + String -> + Int -> + [String] -> + ConversionBenchmarkDigest -> + Either GhcSurfaceBenchmarkObstruction () +validateCommonDigest corpusLabel expectedBindingCount expectedBinders digest + | semanticManifestBindingCount semanticManifest /= expectedBindingCount = + Left + ( UnexpectedBindingCardinality + corpusLabel + expectedBindingCount + (semanticManifestBindingCount semanticManifest) + ) + | semanticManifestOrderedBinders semanticManifest /= expectedBinders = + Left + ( UnexpectedOrderedBinders + corpusLabel + expectedBinders + (semanticManifestOrderedBinders semanticManifest) + ) + | otherwise = + Right () + where + semanticManifest = conversionSemanticManifest digest + +orderedBindingNames :: ConvertedModule -> [String] +orderedBindingNames = + foldMap + (fmap renderRdrName . bindingNames . tlbBinding) + . convertedModuleBindings + +representationReadinessDigest :: + String -> + ConvertedModule -> + Either GhcSurfaceBenchmarkObstruction RepresentationReadinessDigest +representationReadinessDigest corpusLabel convertedModule = do + scopeContexts <- + first + (BenchmarkScopeMetadataRejected corpusLabel) + (scopeObservedContexts (cmScopeIndex convertedModule)) + let metrics = convertedModuleMetrics convertedModule + annotationDigest = + foldl' + digestConvertedValueBindingAnnotations + ( foldl' + digestBinderAnn + ( foldl' + digestBinderAnn + (foldl' digestScopeContext 2166136261 scopeContexts) + (cmLambdaSites convertedModule) + ) + (cmLetSites convertedModule) + ) + (convertedModuleBindings convertedModule) + pure + RepresentationReadinessDigest + { readinessBindingCount = cmmBindingCount metrics, + readinessObservedContextCount = cmmObservedContextCount metrics, + readinessLambdaSiteCount = cmmLambdaSiteCount metrics, + readinessLetSiteCount = cmmLetSiteCount metrics, + readinessScopedExprCount = cmmScopedExprCount metrics, + readinessGlobalVarRefCount = cmmGlobalVarRefCount metrics, + readinessLocalVarRefCount = cmmLocalVarRefCount metrics, + readinessMaxFreeScopeCount = cmmMaxFreeScopeCount metrics, + readinessAnnotationDigest = annotationDigest + } + +digestConvertedValueBindingAnnotations :: Int -> ConvertedValueBinding -> Int +digestConvertedValueBindingAnnotations digest convertedValueBinding = + digestBindingAnnotations + ( digestSourceRegion + (digestInt digest (scopeIdKey (tlbScope convertedValueBinding))) + (tlbRegion convertedValueBinding) + ) + (tlbBinding convertedValueBinding) + +digestBindingAnnotations :: Int -> Binding -> Int +digestBindingAnnotations digest = \case + FunctionBinding binderAnn clauses -> + foldl' + digestClauseAnnotations + (digestBinderAnn digest binderAnn) + clauses + PatternBinding _ rhsValue -> + digestRhsAnnotations digest rhsValue + +digestClauseAnnotations :: Int -> Clause -> Int +digestClauseAnnotations digest clauseValue = + digestRhsAnnotations digest (clauseRhs clauseValue) + +digestRhsAnnotations :: Int -> Rhs -> Int +digestRhsAnnotations digest = \case + UnguardedRhs bodyExpression maybeBindingGroup -> + foldl' + digestBindingGroupAnnotations + (digestExprAnnotations digest bodyExpression) + maybeBindingGroup + GuardedRhs guardedAlternatives maybeBindingGroup -> + foldl' + digestBindingGroupAnnotations + ( foldl' + digestExprAnnotations + digest + (foldMap toList guardedAlternatives) + ) + maybeBindingGroup + +digestBindingGroupAnnotations :: Int -> BindingGroup -> Int +digestBindingGroupAnnotations digest bindingGroup = + foldl' + digestBindingAnnotations + (digestInt digest (scopeIdKey (bindingGroupScope bindingGroup))) + (bindingGroupBindings bindingGroup) + +digestExprAnnotations :: Int -> Expr -> Int +digestExprAnnotations digest expressionValue = + foldl' + digestExprAnnotations + ( foldl' + (\nestedDigest scopeId -> digestInt nestedDigest (scopeIdKey scopeId)) + ( digestSourceRegion + (digestInt digest (scopeIdKey (exprScope expressionValue))) + (exprRegion expressionValue) + ) + (freeScopeSummaryToList (exprFreeScopes expressionValue)) + ) + (exprNode expressionValue) + +digestBinderAnn :: Int -> BinderAnn -> Int +digestBinderAnn digest binderAnn = + foldl' + (\nestedDigest character -> digestInt nestedDigest (fromEnum character)) + (digestInt digest (binderIdKey (baId binderAnn))) + (renderRdrName (baName binderAnn)) + +digestSourceRegion :: Int -> Maybe SourceRegion -> Int +digestSourceRegion digest = \case + Nothing -> + digestInt digest 0 + Just region -> + digestInt + ( digestInt + (digestInt (digestInt digest (srStartLine region)) (srStartCol region)) + (srEndLine region) + ) + (srEndCol region) + +digestScopeContext :: Int -> ScopeCtx -> Int +digestScopeContext digest = \case + ActualScope scopeId -> + digestInt digest (scopeIdKey scopeId) + IncompatibleScope -> + digestInt digest (-1) + +digestInt :: Int -> Int -> Int +digestInt digest value = + (digest * 16777619) + value + +digestString :: Int -> String -> Int +digestString = + foldl' + (\digest character -> digestInt digest (fromEnum character)) + +commonSubsetModule :: Int -> String +commonSubsetModule bindingCount = + unlines ("module Bench where" : "" : fmap binding [1 .. bindingCount]) + where + binding :: Int -> String + binding index = + let name = show index + in "f" <> name <> " x = let y = x + " <> name <> " in h" <> name <> " (y * y)" + +fullFidelityModule :: String +fullFidelityModule = + unlines + [ "{-# LANGUAGE MagicHash #-}", + "{-# LANGUAGE TupleSections #-}", + "{-# LANGUAGE UnboxedTuples #-}", + "module Bench where", + "", + "infixr 5 <+>", + "(<+>) left right = left + right", + "", + "(answer, label) = (42, \"exact\")", + "tupleSection value = (, value)", + "unboxed value = (# value, value + 1 #)", + "exactFraction = 1.25", + "primitiveString = \"bytes\"#", + "multi [] = 0", + "multi (value : values) = local value + multi values", + " where", + " local nested = nested <+> 1" + ] + +scopeDepthModule :: Int -> String +scopeDepthModule depth = + unlines + [ "module Bench where", + "", + "deep = " + <> foldr + (\binderName bodySource -> "\\" <> binderName <> " -> " <> bodySource) + ("level" <> show depth) + binderNames + ] + where + binderNames = + fmap (\index -> "level" <> show index) [1 .. depth] + +scopeBranchModule :: Int -> String +scopeBranchModule branchCount = + unlines + ( [ "module Bench where", + "", + "branch value = case value of" + ] + <> fmap branchRow [1 .. branchCount] + ) + where + branchRow :: Int -> String + branchRow index = + " Branch" <> show index <> " branchValue -> branchValue" + +shadowDepthModule :: Int -> String +shadowDepthModule depth = + unlines + [ "module Bench where", + "", + "shadow = " + <> foldr + (\_ bodySource -> "\\value -> " <> bodySource) + "value" + [1 .. depth] + ] + +sparseSccModule :: Int -> String +sparseSccModule cardinality = + unlines + ( [ "module Bench where", + "", + "sparse seed =", + " let" + ] + <> fmap sparseBindingRow [1 .. cardinality] + <> [" in node1"] + ) + where + sparseBindingRow index = + " node" + <> show index + <> " = node" + <> show (if index == cardinality then 1 else index + 1) + <> " + seed" + +denseSccModule :: Int -> String +denseSccModule cardinality = + unlines + ( [ "module Bench where", + "", + "dense seed =", + " let" + ] + <> fmap denseBindingRow [1 .. cardinality] + <> [" in node1"] + ) + where + denseBindingRow index = + " node" + <> show index + <> " = " + <> intercalate + " + " + ( "seed" + : fmap + (\referencedIndex -> "node" <> show referencedIndex) + (filter (/= index) [1 .. cardinality]) + ) + +renderedListModule :: Int -> String +renderedListModule elementCount = + unlines + [ "module Bench where", + "", + "rendered = [" <> intercalate ", " (fmap show [1 .. elementCount]) <> "]" + ] + +opaqueDeclarationPositionModule :: Int -> String +opaqueDeclarationPositionModule declarationPosition = + unlines + ( ["module Bench where", ""] + <> precedingBindings + <> [ "class BenchClass value where", + " benchMethod :: value -> value" + ] + <> remainingBindings + ) + where + allBindings = + fmap + (\index -> "value" <> show index <> " = " <> show index) + [1 .. opaquePositionBindingCount] + (precedingBindings, remainingBindings) = + splitAt declarationPosition allBindings + +opaquePositionBindingCount :: Int +opaquePositionBindingCount = + 128 diff --git a/bench/ghc-surface/HieBench.hs b/bench/ghc-surface/HieBench.hs new file mode 100644 --- /dev/null +++ b/bench/ghc-surface/HieBench.hs @@ -0,0 +1,640 @@ +-- Current HIE type-graph property workload. The historical encoder unfolds +-- the same doubling DAG exponentially, so these rows certify the exact current +-- linear wire law rather than manufacturing a ratio between different wire +-- contracts. +module HieBench + ( HieBenchmarkObstruction (..), + hieBenchmarks, + ) +where + +import BenchSupport (preparedBenchmarks) +import Control.DeepSeq (NFData (rnf)) +import Data.Array (Array, array, assocs) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Word (Word64) +import GHC.Iface.Ext.Types (HieArgs (..), HieType (..), HieTypeFlat, TypeIndex) +import GHC.Types.Name (Name, mkSystemName) +import GHC.Types.Name.Occurrence (mkTyVarOcc) +import GHC.Types.Unique (mkUnique) +import Language.Haskell.Syntax.Specificity (data Specified) +import Moonlight.Pale.Ghc.Hie.Oracle (ModuleNameOracle (..)) +import Moonlight.Pale.Ghc.Hie.SourceKey + ( HieOracleArtifact (..), + HieSourceKeyKind (..), + OracleLookup (..), + OracleQuery (..), + buildHieOracleIndex, + lookupModuleOracle, + ) +import Moonlight.Pale.Ghc.Hie.TypeWords + ( TypeGraphObstruction (..), + TypeWords, + hieTypeIndexTypeWords, + hieTypeRootsTypeWords, + typeWordsList, + ) +import Test.Tasty.Bench (Benchmark, bgroup) + +data HieBenchmarkObstruction + = HieGraphCompilationRejected !Int !TypeGraphObstruction + | HieRootSetCompilationRejected !Int !TypeGraphObstruction + | UnexpectedHieWireLength !Int !Int !Int + | UnexpectedHieRootCount !Int !Int !Int + | InvalidHieFailureCorpusAccepted !String + | UnexpectedHieFailureObstruction !String !TypeGraphObstruction + | UnexpectedSourceKeyLookup !String !OracleLookup + deriving stock (Eq, Show) + +instance NFData HieBenchmarkObstruction where + rnf obstruction = + rnf (show obstruction) + +data HieWireDigest = HieWireDigest + { hieWireWordCount :: !Int, + hieWireWordHash :: !Word64 + } + deriving stock (Eq, Show) + +instance NFData HieWireDigest where + rnf (HieWireDigest wordCount wordHash) = + rnf wordCount `seq` rnf wordHash + +data PreparedHieCorpus = PreparedHieCorpus + { preparedHieDepth :: !Int, + preparedHieTypeTable :: !(Array TypeIndex HieTypeFlat) + } + +instance NFData PreparedHieCorpus where + rnf corpus = + rnf (preparedHieDepth corpus) + `seq` forceTypeTable (preparedHieTypeTable corpus) + +forceTypeTable :: Array TypeIndex HieTypeFlat -> () +forceTypeTable = + foldr forceTypeEntry () . assocs + +forceTypeEntry :: (TypeIndex, HieTypeFlat) -> () -> () +forceTypeEntry (typeIndex, flatType) forcedTail = + rnf typeIndex + `seq` case flatType of + HCoercionTy -> + forcedTail + HAppTy functionIndex (HieArgs argumentIndices) -> + rnf functionIndex + `seq` foldr + ( \(visible, argumentIndex) nestedTail -> + rnf visible `seq` rnf argumentIndex `seq` nestedTail + ) + forcedTail + argumentIndices + HCastTy childIndex -> + rnf childIndex `seq` forcedTail + HForAllTy ((binderName, binderKind), specificity) bodyIndex -> + binderName + `seq` rnf binderKind + `seq` specificity + `seq` rnf bodyIndex + `seq` forcedTail + HTyVarTy variableName -> + variableName `seq` forcedTail + otherFlatType -> + otherFlatType `seq` forcedTail + +data PreparedTypeGraphCorpus = PreparedTypeGraphCorpus + { preparedTypeGraphSize :: !Int, + preparedTypeGraphRoot :: !TypeIndex, + preparedTypeGraphTable :: !(Array TypeIndex HieTypeFlat) + } + +instance NFData PreparedTypeGraphCorpus where + rnf corpus = + rnf (preparedTypeGraphSize corpus) + `seq` rnf (preparedTypeGraphRoot corpus) + `seq` forceTypeTable (preparedTypeGraphTable corpus) + +data PreparedRootSetCorpus = PreparedRootSetCorpus + { preparedRootSetSize :: !Int, + preparedRootSetRoots :: !(Set TypeIndex), + preparedRootSetTable :: !(Array TypeIndex HieTypeFlat) + } + +instance NFData PreparedRootSetCorpus where + rnf corpus = + rnf (preparedRootSetSize corpus) + `seq` rnf (Set.toAscList (preparedRootSetRoots corpus)) + `seq` forceTypeTable (preparedRootSetTable corpus) + +data SourceKeyExpectation + = ExpectLongestSingleton + | ExpectAmbiguousSuffix + deriving stock (Eq, Show) + +data PreparedSourceKeyCorpus = PreparedSourceKeyCorpus + { preparedSourceKeyLabel :: !String, + preparedSourceKeyPaths :: ![FilePath], + preparedSourceKeyQuery :: !OracleQuery, + preparedSourceKeyExpectation :: !SourceKeyExpectation + } + +instance NFData PreparedSourceKeyCorpus where + rnf corpus = + rnf (preparedSourceKeyLabel corpus) + `seq` rnf (preparedSourceKeyPaths corpus) + `seq` rnf (show (preparedSourceKeyQuery corpus)) + `seq` rnf (show (preparedSourceKeyExpectation corpus)) + +data SourceKeyDigest = SourceKeyDigest + { sourceKeyDigestCandidateCount :: !Int, + sourceKeyDigestHash :: !Int + } + deriving stock (Eq, Show) + +instance NFData SourceKeyDigest where + rnf digest = + rnf (sourceKeyDigestCandidateCount digest) + `seq` rnf (sourceKeyDigestHash digest) + +hieBenchmarks :: Either HieBenchmarkObstruction Benchmark +hieBenchmarks = do + validateInvalidHieCorpora + preparedCorpora <- traverse prepareHieCorpus currentHieDepths + graphBenchmarks <- traverse prepareTypeGraphBenchmark typeGraphFamilies + repeatedRootCorpora <- traverse prepareRepeatedRootCorpus repeatedRootSizes + sourceKeyBenchmarks <- traverse prepareSourceKeyBenchmark sourceKeyFamilies + pure + ( bgroup + "hie-type-words" + [ bgroup + "doubling-dag-linear-wire" + (preparedBenchmarks "depth" preparedCorpora compileHieWireDigest), + bgroup + "adversarial-type-graphs" + graphBenchmarks, + bgroup + "repeated-structural-roots" + (preparedBenchmarks "roots" repeatedRootCorpora compileRepeatedRootDigest), + bgroup + "source-path-collisions" + sourceKeyBenchmarks + ] + ) + +currentHieDepths :: [Int] +currentHieDepths = + [8, 16, 32, 128, 512] + +typeGraphFamilies :: + [(String, [Int], Int -> (TypeIndex, Array TypeIndex HieTypeFlat))] +typeGraphFamilies = + [ ("diamond-fanout", [8, 64, 512], diamondFanoutCorpus), + ("deep-forall", [8, 32, 128], deepForAllCorpus), + ("variable-rich-doubling", [8, 32, 128, 512], variableRichDoublingCorpus) + ] + +prepareTypeGraphBenchmark :: + (String, [Int], Int -> (TypeIndex, Array TypeIndex HieTypeFlat)) -> + Either HieBenchmarkObstruction Benchmark +prepareTypeGraphBenchmark (familyLabel, sizes, corpusForSize) = do + preparedCorpora <- + traverse + ( \size -> do + let (rootIndex, typeTable) = corpusForSize size + corpus = + PreparedTypeGraphCorpus + { preparedTypeGraphSize = size, + preparedTypeGraphRoot = rootIndex, + preparedTypeGraphTable = typeTable + } + _ <- compileTypeGraphDigest corpus + pure (size, corpus) + ) + sizes + pure + ( bgroup + familyLabel + (preparedBenchmarks "size" preparedCorpora compileTypeGraphDigest) + ) + +compileTypeGraphDigest :: + PreparedTypeGraphCorpus -> + Either HieBenchmarkObstruction HieWireDigest +compileTypeGraphDigest corpus = + case + hieTypeIndexTypeWords + (preparedTypeGraphTable corpus) + (preparedTypeGraphRoot corpus) + of + Left obstruction -> + Left (HieGraphCompilationRejected (preparedTypeGraphSize corpus) obstruction) + Right typeWordsValue -> + Right (foldl' digestHieWord emptyHieWireDigest (typeWordsList typeWordsValue)) + +repeatedRootSizes :: [Int] +repeatedRootSizes = + [8, 64, 512] + +prepareRepeatedRootCorpus :: + Int -> + Either HieBenchmarkObstruction (Int, PreparedRootSetCorpus) +prepareRepeatedRootCorpus rootCount = do + let corpus = + PreparedRootSetCorpus + { preparedRootSetSize = rootCount, + preparedRootSetRoots = Set.fromList [1 .. fromIntegral rootCount], + preparedRootSetTable = repeatedRootTable rootCount + } + _ <- compileRepeatedRootDigest corpus + pure (rootCount, corpus) + +compileRepeatedRootDigest :: + PreparedRootSetCorpus -> + Either HieBenchmarkObstruction HieWireDigest +compileRepeatedRootDigest corpus = do + compiledRoots <- + firstRootFailure + (preparedRootSetSize corpus) + ( hieTypeRootsTypeWords + (preparedRootSetTable corpus) + (preparedRootSetRoots corpus) + ) + let actualRootCount = Map.size compiledRoots + if actualRootCount /= preparedRootSetSize corpus + then + Left + ( UnexpectedHieRootCount + (preparedRootSetSize corpus) + (preparedRootSetSize corpus) + actualRootCount + ) + else + Right + ( Map.foldlWithKey' + digestCompiledRoot + emptyHieWireDigest + compiledRoots + ) + +firstRootFailure :: + Int -> + Map.Map TypeIndex (Either TypeGraphObstruction typeWords) -> + Either HieBenchmarkObstruction (Map.Map TypeIndex typeWords) +firstRootFailure rootCount = + traverse + (either (Left . HieRootSetCompilationRejected rootCount) Right) + +digestCompiledRoot :: HieWireDigest -> TypeIndex -> TypeWords -> HieWireDigest +digestCompiledRoot digest rootIndex typeWordsValue = + foldl' + digestHieWord + (digestHieWord digest (fromIntegral rootIndex)) + (typeWordsList typeWordsValue) + +sourceKeyFamilies :: [(String, SourceKeyExpectation)] +sourceKeyFamilies = + [ ("longest-singleton-suffix", ExpectLongestSingleton), + ("ambiguous-shared-suffix", ExpectAmbiguousSuffix) + ] + +prepareSourceKeyBenchmark :: + (String, SourceKeyExpectation) -> + Either HieBenchmarkObstruction Benchmark +prepareSourceKeyBenchmark (familyLabel, expectation) = do + preparedCorpora <- + traverse + (prepareSourceKeyCorpus familyLabel expectation) + [8, 64, 512] + pure + ( bgroup + familyLabel + (preparedBenchmarks "paths" preparedCorpora compileSourceKeyDigest) + ) + +prepareSourceKeyCorpus :: + String -> + SourceKeyExpectation -> + Int -> + Either HieBenchmarkObstruction (Int, PreparedSourceKeyCorpus) +prepareSourceKeyCorpus familyLabel expectation pathCount = do + let corpus = + PreparedSourceKeyCorpus + { preparedSourceKeyLabel = familyLabel <> "/" <> show pathCount, + preparedSourceKeyPaths = + fmap + (\pathIndex -> "pkg" <> show pathIndex <> "/src/Foo.hs") + [1 .. pathCount], + preparedSourceKeyQuery = + OracleQuery + { oqGivenPath = + case expectation of + ExpectLongestSingleton -> + "/workspace/pkg1/src/Foo.hs" + ExpectAmbiguousSuffix -> + "/workspace/src/Foo.hs", + oqAbsolutePath = Nothing, + oqSourceRoots = [] + }, + preparedSourceKeyExpectation = expectation + } + _ <- compileSourceKeyDigest corpus + pure (pathCount, corpus) + +compileSourceKeyDigest :: + PreparedSourceKeyCorpus -> + Either HieBenchmarkObstruction SourceKeyDigest +compileSourceKeyDigest corpus = + let lookupResult = + lookupModuleOracle + (buildHieOracleIndex (fmap emptyArtifact (preparedSourceKeyPaths corpus))) + (preparedSourceKeyQuery corpus) + in case (preparedSourceKeyExpectation corpus, lookupResult) of + (ExpectLongestSingleton, OracleFound ModuleSuffixKey artifact) -> + Right + SourceKeyDigest + { sourceKeyDigestCandidateCount = 1, + sourceKeyDigestHash = + digestString + 2166136261 + (mnoSourcePath (hieArtifactOracle artifact)) + } + (ExpectAmbiguousSuffix, OracleAmbiguous ModuleSuffixKey matchedPath candidates) -> + Right + SourceKeyDigest + { sourceKeyDigestCandidateCount = length candidates, + sourceKeyDigestHash = + foldl' + digestString + (digestString 2166136261 matchedPath) + candidates + } + _ -> + Left + ( UnexpectedSourceKeyLookup + (preparedSourceKeyLabel corpus) + lookupResult + ) + +emptyOracle :: FilePath -> ModuleNameOracle +emptyOracle sourcePath = + ModuleNameOracle + { mnoSourcePath = sourcePath, + mnoGlobalUsesAtSpan = Map.empty, + mnoGlobalUses = Map.empty, + mnoEvidenceAtSpan = Map.empty, + mnoTypeAtSpan = Map.empty + } + +emptyArtifact :: FilePath -> HieOracleArtifact +emptyArtifact sourcePath = + HieOracleArtifact + { hieArtifactPath = sourcePath <> ".hie", + hieArtifactOracle = emptyOracle sourcePath + } + +validateInvalidHieCorpora :: Either HieBenchmarkObstruction () +validateInvalidHieCorpora = do + expectHieObstruction + "cycle" + (CyclicTypeIndex 0) + (hieTypeIndexTypeWords (array (0, 0) [(0, HCastTy 0)]) 0) + expectHieObstruction + "out-of-range" + (MissingTypeIndex 1) + (hieTypeIndexTypeWords (array (0, 0) [(0, HCastTy 1)]) 0) + +expectHieObstruction :: + String -> + TypeGraphObstruction -> + Either TypeGraphObstruction typeWords -> + Either HieBenchmarkObstruction () +expectHieObstruction corpusLabel expectedObstruction = \case + Right _ -> + Left (InvalidHieFailureCorpusAccepted corpusLabel) + Left actualObstruction + | actualObstruction == expectedObstruction -> + Right () + | otherwise -> + Left + ( UnexpectedHieFailureObstruction + corpusLabel + actualObstruction + ) + +prepareHieCorpus :: Int -> Either HieBenchmarkObstruction (Int, PreparedHieCorpus) +prepareHieCorpus depth = do + let corpus = + PreparedHieCorpus + { preparedHieDepth = depth, + preparedHieTypeTable = doublingDagTable depth + } + _ <- compileHieWireDigest corpus + pure (depth, corpus) + +compileHieWireDigest :: PreparedHieCorpus -> Either HieBenchmarkObstruction HieWireDigest +compileHieWireDigest corpus = + case + hieTypeIndexTypeWords + (preparedHieTypeTable corpus) + (fromIntegral (preparedHieDepth corpus)) + of + Left obstruction -> + Left (HieGraphCompilationRejected (preparedHieDepth corpus) obstruction) + Right typeWordsValue -> + let digest = foldl' digestHieWord emptyHieWireDigest (typeWordsList typeWordsValue) + expectedLength = currentHieWireLength (preparedHieDepth corpus) + in if hieWireWordCount digest == expectedLength + then Right digest + else + Left + ( UnexpectedHieWireLength + (preparedHieDepth corpus) + expectedLength + (hieWireWordCount digest) + ) + +emptyHieWireDigest :: HieWireDigest +emptyHieWireDigest = + HieWireDigest + { hieWireWordCount = 0, + hieWireWordHash = 14695981039346656037 + } + +digestHieWord :: HieWireDigest -> Word64 -> HieWireDigest +digestHieWord digest wordValue = + HieWireDigest + { hieWireWordCount = hieWireWordCount digest + 1, + hieWireWordHash = (hieWireWordHash digest * 1099511628211) + wordValue + } + +currentHieWireLength :: Int -> Int +currentHieWireLength depth = + (7 * depth) + 7 + +doublingDagTable :: Int -> Array TypeIndex HieTypeFlat +doublingDagTable depth = + array + (0, fromIntegral depth) + ( (0, HCoercionTy) + : fmap + ( \typeIndex -> + ( typeIndex, + HAppTy + (typeIndex - 1) + (HieArgs [(True, typeIndex - 1)]) + ) + ) + [1 .. fromIntegral depth] + ) + +diamondFanoutCorpus :: Int -> (TypeIndex, Array TypeIndex HieTypeFlat) +diamondFanoutCorpus fanout = + let branchIndices = + [2 .. fromIntegral fanout + 1] + rootIndex = + fromIntegral fanout + 2 + in ( rootIndex, + array + (0, rootIndex) + ( [ (0, HCoercionTy), + (1, HCastTy 0) + ] + <> fmap + (\branchIndex -> (branchIndex, HAppTy 1 (HieArgs [(True, 0)]))) + branchIndices + <> [ ( rootIndex, + HAppTy + 1 + (HieArgs (fmap (\branchIndex -> (True, branchIndex)) branchIndices)) + ) + ] + ) + ) + +deepForAllCorpus :: Int -> (TypeIndex, Array TypeIndex HieTypeFlat) +deepForAllCorpus depth = + let binderNames = + fmap hieBinderName [1 .. depth] + innermostVariableIndex = + 1 + forallEntries = + fmap + ( \(entryOffset, binderName) -> + let forallIndex = + fromIntegral entryOffset + 2 + bodyIndex = + if entryOffset == 0 + then innermostVariableIndex + else forallIndex - 1 + in ( forallIndex, + HForAllTy + ((binderName, 0), Specified) + bodyIndex + ) + ) + (zip [0 :: Int ..] (reverse binderNames)) + rootIndex = + fromIntegral depth + 1 + innermostBinderName = + maybe (hieBinderName 0) id (lastMaybe binderNames) + in ( rootIndex, + array + (0, rootIndex) + ( [ (0, HCoercionTy), + (innermostVariableIndex, HTyVarTy innermostBinderName) + ] + <> forallEntries + ) + ) + +variableRichDoublingCorpus :: + Int -> + (TypeIndex, Array TypeIndex HieTypeFlat) +variableRichDoublingCorpus requestedSize = + let variableCount = + max 1 requestedSize + wrapperDepth = + max 1 requestedSize + variableEntries = + fmap + ( \variableOffset -> + ( fromIntegral variableOffset, + HTyVarTy (hieFreeVariableName (variableOffset + 1)) + ) + ) + [0 .. variableCount - 1] + combinationEntries = + fmap + ( \combinationOffset -> + let combinationIndex = + fromIntegral (variableCount + combinationOffset) + functionIndex = + if combinationOffset == 0 + then 0 + else combinationIndex - 1 + argumentIndex = + fromIntegral (combinationOffset + 1) + in ( combinationIndex, + HAppTy + functionIndex + (HieArgs [(True, argumentIndex)]) + ) + ) + [0 .. variableCount - 2] + combinedRootIndex = + if variableCount == 1 + then 0 + else fromIntegral ((2 * variableCount) - 2) + wrapperEntries = + fmap + ( \wrapperOffset -> + let wrapperIndex = + combinedRootIndex + fromIntegral wrapperOffset + childIndex = + wrapperIndex - 1 + in ( wrapperIndex, + HAppTy + childIndex + (HieArgs [(True, childIndex)]) + ) + ) + [1 .. wrapperDepth] + rootIndex = + combinedRootIndex + fromIntegral wrapperDepth + in ( rootIndex, + array + (0, rootIndex) + (variableEntries <> combinationEntries <> wrapperEntries) + ) + +lastMaybe :: [value] -> Maybe value +lastMaybe = + foldl' (\_ value -> Just value) Nothing + +hieBinderName :: Int -> Name +hieBinderName binderIndex = + mkSystemName + (mkUnique 'h' (fromIntegral binderIndex)) + (mkTyVarOcc ("type" <> show binderIndex)) + +hieFreeVariableName :: Int -> Name +hieFreeVariableName variableIndex = + mkSystemName + (mkUnique 'v' (fromIntegral variableIndex)) + (mkTyVarOcc ("free" <> show variableIndex)) + +repeatedRootTable :: Int -> Array TypeIndex HieTypeFlat +repeatedRootTable rootCount = + array + (0, fromIntegral rootCount) + ( (0, HCoercionTy) + : fmap + (\rootIndex -> (rootIndex, HCastTy 0)) + [1 .. fromIntegral rootCount] + ) + +digestString :: Int -> String -> Int +digestString = + foldl' + (\digest character -> (digest * 16777619) + fromEnum character) diff --git a/bench/ghc-surface/Main.hs b/bench/ghc-surface/Main.hs new file mode 100644 --- /dev/null +++ b/bench/ghc-surface/Main.hs @@ -0,0 +1,25 @@ +module Main + ( main, + ) +where + +import GhcSurfaceBench (ghcSurfaceBenchmarks) +import HieBench (hieBenchmarks) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + case (ghcSurfaceBenchmarks, hieBenchmarks) of + (Left obstruction, _) -> + rejectBenchmarkCorpus "GHC surface" obstruction + (_, Left obstruction) -> + rejectBenchmarkCorpus "HIE type graph" obstruction + (Right surfaceBenchmarks, Right hieTypeBenchmarks) -> + defaultMain [surfaceBenchmarks, hieTypeBenchmarks] + +rejectBenchmarkCorpus :: Show obstruction => String -> obstruction -> IO () +rejectBenchmarkCorpus corpusLabel obstruction = do + hPutStrLn stderr ("moonlight-pale " <> corpusLabel <> " benchmark corpus rejected: " <> show obstruction) + exitFailure diff --git a/bench/laws/LawBench.hs b/bench/laws/LawBench.hs new file mode 100644 --- /dev/null +++ b/bench/laws/LawBench.hs @@ -0,0 +1,266 @@ +-- Current finite-law construction workloads. Dense lattice rows certify the +-- complete join/meet witness. Restriction rows time checked quadratic relation +-- construction; historical unchecked seeds are deliberately excluded. +module LawBench + ( LawBenchmarkObstruction (..), + lawBenchmarks, + ) +where + +import BenchSupport (preparedBenchmarks) +import Control.DeepSeq (NFData (rnf)) +import Control.Monad (foldM) +import Data.Bifunctor (first) +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty (..)) +import Moonlight.Pale.Test.Laws.Lattice + ( FiniteLattice, + FiniteLatticeError, + FiniteLatticeLookupError, + LatticeBounds (..), + compileFiniteLattice, + finiteLatticeJoin, + finiteLatticeMeet, + ) +import Moonlight.Pale.Test.Laws.Restriction + ( FiniteRestrictionError (..), + compileFiniteRestrictionLaw, + ) +import Test.Tasty.Bench (Benchmark, bgroup) + +data LawBenchmarkObstruction + = LatticeCompilationRejected !Int !(NonEmpty (FiniteLatticeError Int)) + | LatticeLookupRejected !Int !(FiniteLatticeLookupError Int) + | UnexpectedLatticeWitness !Int !Integer !Integer + | RestrictionCompilationRejected !Int !(NonEmpty (FiniteRestrictionError Int)) + | InvalidRestrictionCorpusAccepted !String + | UnexpectedRestrictionObstruction !String !(NonEmpty (FiniteRestrictionError Int)) + deriving stock (Eq, Show) + +instance NFData LawBenchmarkObstruction where + rnf obstruction = + rnf (show obstruction) + +data ChainCorpus = ChainCorpus + { chainCardinality :: !Int, + chainUniverse :: !(NonEmpty Int) + } + +instance NFData ChainCorpus where + rnf corpus = + rnf (chainCardinality corpus) + `seq` rnf (chainUniverse corpus) + +data LatticeWitnessDigest = LatticeWitnessDigest + { latticeWitnessPairs :: !Int, + latticeWitnessOperationSum :: !Integer, + latticeWitnessHash :: !Int + } + deriving stock (Eq, Show) + +instance NFData LatticeWitnessDigest where + rnf digest = + rnf (latticeWitnessPairs digest) + `seq` rnf (latticeWitnessOperationSum digest) + `seq` rnf (latticeWitnessHash digest) + +data RestrictionCompilationDigest = RestrictionCompilationDigest + { restrictionCellCount :: !Int, + restrictionSectionCount :: !Int, + restrictionActionCount :: !Integer + } + deriving stock (Eq, Show) + +instance NFData RestrictionCompilationDigest where + rnf digest = + rnf (restrictionCellCount digest) + `seq` rnf (restrictionSectionCount digest) + `seq` rnf (restrictionActionCount digest) + +lawBenchmarks :: Either LawBenchmarkObstruction Benchmark +lawBenchmarks = do + _ <- validateInvalidRestrictionCorpora + preparedLattices <- traverse prepareLatticeCorpus lawSizes + preparedRestrictions <- traverse prepareRestrictionCorpus lawSizes + pure + ( bgroup + "finite-laws" + [ bgroup + "dense-chain-lattice-compile-and-witness" + (preparedBenchmarks "cardinality" preparedLattices compileLatticeWitness), + bgroup + "chain-restriction-compile" + (preparedBenchmarks "cardinality" preparedRestrictions compileRestrictionDigest) + ] + ) + +lawSizes :: [Int] +lawSizes = + [32, 64, 128] + +prepareLatticeCorpus :: Int -> Either LawBenchmarkObstruction (Int, ChainCorpus) +prepareLatticeCorpus cardinality = do + let corpus = chainCorpus cardinality + _ <- compileLatticeWitness corpus + pure (cardinality, corpus) + +prepareRestrictionCorpus :: Int -> Either LawBenchmarkObstruction (Int, ChainCorpus) +prepareRestrictionCorpus cardinality = do + let corpus = chainCorpus cardinality + _ <- compileRestrictionDigest corpus + pure (cardinality, corpus) + +chainCorpus :: Int -> ChainCorpus +chainCorpus cardinality = + ChainCorpus + { chainCardinality = cardinality, + chainUniverse = 0 :| [1 .. cardinality - 1] + } + +compileLatticeWitness :: ChainCorpus -> Either LawBenchmarkObstruction LatticeWitnessDigest +compileLatticeWitness corpus = do + lattice <- + first + (LatticeCompilationRejected (chainCardinality corpus)) + ( compileFiniteLattice + "benchmark chain" + (chainUniverse corpus) + max + min + (Just (LatticeBounds 0 (chainCardinality corpus - 1))) + ) + witness <- + foldM + (digestLatticeRow lattice (chainUniverse corpus) (chainCardinality corpus)) + emptyLatticeWitness + (chainUniverse corpus) + let expectedSum = + toInteger (chainCardinality corpus) + * toInteger (chainCardinality corpus) + * toInteger (chainCardinality corpus - 1) + if latticeWitnessOperationSum witness == expectedSum + then Right witness + else + Left + ( UnexpectedLatticeWitness + (chainCardinality corpus) + expectedSum + (latticeWitnessOperationSum witness) + ) + +digestLatticeRow :: + FiniteLattice Int -> + NonEmpty Int -> + Int -> + LatticeWitnessDigest -> + Int -> + Either LawBenchmarkObstruction LatticeWitnessDigest +digestLatticeRow lattice universe cardinality digest leftValue = + foldM + (digestLatticePair lattice cardinality leftValue) + digest + universe + +digestLatticePair :: + FiniteLattice Int -> + Int -> + Int -> + LatticeWitnessDigest -> + Int -> + Either LawBenchmarkObstruction LatticeWitnessDigest +digestLatticePair lattice cardinality leftValue digest rightValue = do + joinValue <- + first + (LatticeLookupRejected cardinality) + (finiteLatticeJoin lattice leftValue rightValue) + meetValue <- + first + (LatticeLookupRejected cardinality) + (finiteLatticeMeet lattice leftValue rightValue) + pure + LatticeWitnessDigest + { latticeWitnessPairs = latticeWitnessPairs digest + 1, + latticeWitnessOperationSum = + latticeWitnessOperationSum digest + + toInteger joinValue + + toInteger meetValue, + latticeWitnessHash = + (((latticeWitnessHash digest * 16777619) + joinValue) * 16777619) + + meetValue + } + +emptyLatticeWitness :: LatticeWitnessDigest +emptyLatticeWitness = + LatticeWitnessDigest + { latticeWitnessPairs = 0, + latticeWitnessOperationSum = 0, + latticeWitnessHash = 2166136261 + } + +compileRestrictionDigest :: ChainCorpus -> Either LawBenchmarkObstruction RestrictionCompilationDigest +compileRestrictionDigest corpus = + case + compileFiniteRestrictionLaw + "benchmark chain" + (chainUniverse corpus) + (<=) + (fmap (\cell -> (cell, cell)) (toList (chainUniverse corpus))) + (\_ targetCell value -> min value targetCell) + of + Left errors -> + Left (RestrictionCompilationRejected (chainCardinality corpus) errors) + Right restrictionLaw -> + restrictionLaw + `seq` Right + RestrictionCompilationDigest + { restrictionCellCount = chainCardinality corpus, + restrictionSectionCount = chainCardinality corpus, + restrictionActionCount = + let cardinality = toInteger (chainCardinality corpus) + in (cardinality * (cardinality + 1)) `div` 2 + } + +validateInvalidRestrictionCorpora :: Either LawBenchmarkObstruction () +validateInvalidRestrictionCorpora = do + expectRestrictionObstruction + "duplicate cells" + (\case DuplicateRestrictionCell {} -> True; _ -> False) + ( compileFiniteRestrictionLaw + "duplicate" + (0 :| [0]) + (<=) + [(0, 0 :: Int)] + (\_ target value -> min value target) + ) + expectRestrictionObstruction + "unknown section cell" + (\case SectionCellOutsideUniverse 2 -> True; _ -> False) + ( compileFiniteRestrictionLaw + "unknown section" + (0 :| [1]) + (<=) + [(2, 2 :: Int)] + (\_ target value -> min value target) + ) + expectRestrictionObstruction + "non-poset" + (\case RestrictionRelationNotReflexive {} -> True; _ -> False) + ( compileFiniteRestrictionLaw + "non-poset" + (0 :| [1]) + (\_ _ -> False) + [(0, 0 :: Int), (1, 1)] + (\_ target value -> min value target) + ) + +expectRestrictionObstruction :: + String -> + (FiniteRestrictionError Int -> Bool) -> + Either (NonEmpty (FiniteRestrictionError Int)) restrictionLaw -> + Either LawBenchmarkObstruction () +expectRestrictionObstruction label matches = \case + Right _ -> + Left (InvalidRestrictionCorpusAccepted label) + Left errors + | any matches errors -> Right () + | otherwise -> Left (UnexpectedRestrictionObstruction label errors) diff --git a/bench/laws/Main.hs b/bench/laws/Main.hs new file mode 100644 --- /dev/null +++ b/bench/laws/Main.hs @@ -0,0 +1,18 @@ +module Main + ( main, + ) +where + +import LawBench (lawBenchmarks) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + case lawBenchmarks of + Left obstruction -> do + hPutStrLn stderr ("moonlight-pale finite-law benchmark corpus rejected: " <> show obstruction) + exitFailure + Right benchmarks -> + defaultMain [benchmarks] diff --git a/bench/receipts/Main.hs b/bench/receipts/Main.hs new file mode 100644 --- /dev/null +++ b/bench/receipts/Main.hs @@ -0,0 +1,134 @@ +module Main + ( main, + ) +where + +import Control.DeepSeq (NFData (rnf), force) +import Control.Exception (evaluate) +import Data.Bifunctor (first) +import Data.Foldable (traverse_) +import Data.Word (Word64) +import DiagnosticBench + ( RestrictionCorpus, + RestrictionDigest (..), + distinctRestrictionCorpus, + outcomeSummaryLeftFold, + outcomeSummaryMconcat, + repeatedRestrictionCorpus, + restrictionHotspotDigest, + restrictionIndexStatsDigest, + ) +import GhcSurfaceBench + ( PreparedConversionCorpus, + commonSubsetSemanticManifests, + conversionBenchmarkDigestHash, + convertCommonCorpus, + prepareCommonSubsetCorpus, + ) +import Moonlight.Pale.Bench.Measure + ( RtsDelta (..), + RtsMeasurement (..), + measureSample, + ) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + +data DiagnosticReceiptSpec = DiagnosticReceiptSpec + { diagnosticReceiptLabel :: !String, + diagnosticReceiptCorpus :: Int -> RestrictionCorpus, + diagnosticReceiptWorkload :: RestrictionCorpus -> RestrictionDigest + } + +data EquivalenceReceipt = EquivalenceReceipt + { receiptLabel :: !String, + receiptElapsedNanoseconds :: !Word64, + receiptAllocatedBytes :: !Word64, + receiptCopiedBytes :: !Word64, + receiptDigest :: !Int + } + deriving stock (Eq, Show) + +main :: IO () +main = + case (commonSubsetSemanticManifests, prepareCommonSubsetCorpus 128) of + (Left obstruction, _) -> + rejectReceipt "semantic manifest" obstruction + (_, Left obstruction) -> + rejectReceipt "conversion input" obstruction + (Right manifests, Right (_, conversionInput)) -> do + diagnosticResults <- traverse measureDiagnosticReceipt diagnosticReceiptSpecs + conversionResult <- measureConversionReceipt conversionInput + case sequence (diagnosticResults <> [conversionResult]) of + Left failure -> do + hPutStrLn stderr ("moonlight-pale equivalence receipt failed: " <> failure) + exitFailure + Right receipts -> do + traverse_ + (putStrLn . ("conversion-semantic-manifest " <>) . show) + manifests + traverse_ print receipts + +rejectReceipt :: Show obstruction => String -> obstruction -> IO () +rejectReceipt receiptLabel obstruction = do + hPutStrLn stderr ("moonlight-pale " <> receiptLabel <> " rejected: " <> show obstruction) + exitFailure + +diagnosticReceiptSpecs :: [DiagnosticReceiptSpec] +diagnosticReceiptSpecs = + foldMap + ( \(regimeLabel, corpusFromSize) -> + fmap + (\(workloadLabel, workload) -> DiagnosticReceiptSpec (regimeLabel <> "/" <> workloadLabel) corpusFromSize workload) + diagnosticWorkloads + ) + [ ("repeated-cardinality", repeatedRestrictionCorpus), + ("distinct-cardinality", distinctRestrictionCorpus) + ] + +diagnosticWorkloads :: [(String, RestrictionCorpus -> RestrictionDigest)] +diagnosticWorkloads = + [ ("outcome-summary-mconcat", outcomeSummaryMconcat), + ("outcome-summary-left-fold", outcomeSummaryLeftFold), + ("restriction-index-stats", restrictionIndexStatsDigest), + ("restriction-hotspots-top-16", restrictionHotspotDigest) + ] + +measureDiagnosticReceipt :: DiagnosticReceiptSpec -> IO (Either String EquivalenceReceipt) +measureDiagnosticReceipt specification = do + measurementResult <- + measureSample + 1 + (\_ -> evaluate (force (diagnosticReceiptCorpus specification 16384))) + (\corpus -> pure (Right (diagnosticReceiptWorkload specification corpus) :: Either String RestrictionDigest)) + rnf + restrictionDigestHash + pure + ( fmap + (measurementReceipt ("diagnostic/" <> diagnosticReceiptLabel specification)) + (first show measurementResult) + ) + +measureConversionReceipt :: PreparedConversionCorpus -> IO (Either String EquivalenceReceipt) +measureConversionReceipt preparedInput = do + measurementResult <- + measureSample + 1 + (\_ -> evaluate (force preparedInput)) + (pure . convertCommonCorpus) + rnf + conversionBenchmarkDigestHash + pure + ( fmap + (measurementReceipt "ghc-surface/common-subset-convert-and-normalize/bindings/128") + (first show measurementResult) + ) + +measurementReceipt :: String -> RtsMeasurement value -> EquivalenceReceipt +measurementReceipt label measurement = + EquivalenceReceipt + { receiptLabel = label, + receiptElapsedNanoseconds = rtsMeasurementElapsedNanoseconds measurement, + receiptAllocatedBytes = rtsDeltaAllocatedBytes (rtsMeasurementDelta measurement), + receiptCopiedBytes = rtsDeltaCopiedBytes (rtsMeasurementDelta measurement), + receiptDigest = rtsMeasurementDigest measurement + } 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,22 @@ +-- Shared benchmark scaffolding for @moonlight-pale@: size-parameterized groups +-- measured on prepared @Int@-indexed inputs, forced to normal form before timing. +module BenchSupport + ( preparedBenchmarks, + ) +where + +import Control.DeepSeq (NFData, force) +import Control.Exception (evaluate) +import Test.Tasty.Bench (Benchmark, bench, env, nf) + +preparedBenchmarks :: + (NFData input, NFData result) => + String -> + [(Int, input)] -> + (input -> result) -> + [Benchmark] +preparedBenchmarks label preparedInputs workload = + [ env (evaluate (force preparedInput)) $ \prepared -> + bench (label <> "/" <> show size) (nf workload prepared) + | (size, preparedInput) <- preparedInputs + ] diff --git a/moonlight-pale.cabal b/moonlight-pale.cabal new file mode 100644 --- /dev/null +++ b/moonlight-pale.cabal @@ -0,0 +1,432 @@ +cabal-version: 3.0 +name: moonlight-pale +version: 0.1.0.0 +homepage: https://github.com/PaleRoses/moonlight +bug-reports: https://github.com/PaleRoses/moonlight/issues +synopsis: Shared diagnostics, law testing, and GHC/HIE tooling for Moonlight. +description: Role-specific public libraries for diagnostics, law testing, benchmarking, GHC/HIE source tooling, and compile-diagnostic support. +license: MIT +license-file: LICENSE +author: Blue Rose +maintainer: rosaliafialkova@gmail.com +category: Development +build-type: Simple +tested-with: GHC == 9.14.1 +extra-doc-files: + README.md + CHANGELOG.md +extra-source-files: + test/compile-diagnostics/fixtures/Trivial.hs + +common shared-properties + default-language: GHC2024 + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wpartial-fields + -Wno-missing-import-lists + +common test-properties + import: shared-properties + +library ghc-surface + import: shared-properties + visibility: public + hs-source-dirs: src-ghc-surface + exposed-modules: + Moonlight.Pale.Ghc.Expr + Moonlight.Pale.Ghc.Expr.Parse + Moonlight.Pale.Ghc.Hie.Oracle + Moonlight.Pale.Ghc.Hie.Read + Moonlight.Pale.Ghc.Hie.SourceKey + Moonlight.Pale.Ghc.Hie.TypeWords + Moonlight.Pale.Ghc.ModuleSurface + other-modules: + Moonlight.Pale.Ghc.Expr.Equivalence + Moonlight.Pale.Ghc.Expr.Render + Moonlight.Pale.Ghc.Expr.Render.Analysis + Moonlight.Pale.Ghc.Expr.Render.Annotation + Moonlight.Pale.Ghc.Expr.Render.Binding + Moonlight.Pale.Ghc.Expr.Render.Carrier + Moonlight.Pale.Ghc.Expr.Render.Document + Moonlight.Pale.Ghc.Expr.Render.Expression + Moonlight.Pale.Ghc.Expr.Render.Literal + Moonlight.Pale.Ghc.Expr.Render.Module + Moonlight.Pale.Ghc.Expr.Render.Name + Moonlight.Pale.Ghc.Expr.Render.Pattern + Moonlight.Pale.Ghc.Expr.Render.Refusal + Moonlight.Pale.Ghc.Expr.Convert.Coalgebra + Moonlight.Pale.Ghc.Expr.Convert.Declaration + Moonlight.Pale.Ghc.Expr.Convert.Dependencies + Moonlight.Pale.Ghc.Expr.Convert.Expression + Moonlight.Pale.Ghc.Expr.Convert.FreeScopes + Moonlight.Pale.Ghc.Expr.Convert.Metrics + Moonlight.Pale.Ghc.Expr.Convert.Obstruction + Moonlight.Pale.Ghc.Expr.Convert.Pattern + Moonlight.Pale.Ghc.Expr.Convert.Projection + Moonlight.Pale.Ghc.Expr.Convert.Row + Moonlight.Pale.Ghc.Expr.Convert.Source + Moonlight.Pale.Ghc.Expr.Convert.State + Moonlight.Pale.Ghc.Expr.NameRender + Moonlight.Pale.Ghc.Expr.Opaque + Moonlight.Pale.Ghc.Expr.Scope + Moonlight.Pale.Ghc.Expr.Syntax + Moonlight.Pale.Ghc.Hie.TypeWords.Internal + build-depends: + base >= 4.22 && < 5 + , array >= 0.5 && < 0.6 + , bytestring >= 0.12 && < 0.13 + , containers >= 0.8 && < 0.9 + , directory >= 1.3 && < 1.4 + , filepath >= 1.5 && < 1.6 + , ghc >= 9.14 && < 9.16 + , ghc-boot-th >= 9.14 && < 9.16 + , moonlight-core >= 0.1 && < 0.2 + , mtl >= 2.3 && < 2.4 + , primitive >= 0.9 && < 0.10 + , prettyprinter >= 1.7 && < 1.8 + , transformers >= 0.6 && < 0.7 + , text >= 2.1 && < 2.2 + , vector >= 0.13 && < 0.14 + +library diagnostic + import: shared-properties + visibility: public + hs-source-dirs: src-diagnostic + exposed-modules: + Moonlight.Pale.Diagnostic.Core + Moonlight.Pale.Diagnostic.Topology.Boundary + Moonlight.Pale.Diagnostic.Topology.Homotopy + Moonlight.Pale.Diagnostic.Topology.Cohomology + Moonlight.Pale.Diagnostic.Summary.Structural + Moonlight.Pale.Diagnostic.Local.Propagation + Moonlight.Pale.Diagnostic.Local.Replay + Moonlight.Pale.Diagnostic.Local.Rewrite + Moonlight.Pale.Diagnostic.Local.Saturation + Moonlight.Pale.Diagnostic.Views.Rewrite + Moonlight.Pale.Diagnostic.Aggregation.Propagation + Moonlight.Pale.Diagnostic.Aggregation.Algebra + build-depends: + base >= 4.22 && < 5 + , containers >= 0.8 && < 0.9 + +library test + import: shared-properties + visibility: public + hs-source-dirs: src-test + exposed-modules: + Moonlight.Pale.Test.Core + Moonlight.Pale.Test.Assertions + Moonlight.Pale.Test.Resources + Moonlight.Pale.Test.Recursion + build-depends: + base >= 4.22 && < 5 + , containers >= 0.8 && < 0.9 + , directory >= 1.3 && < 1.4 + , filepath >= 1.5 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + +library measurement + import: shared-properties + visibility: public + hs-source-dirs: src-bench + exposed-modules: + Moonlight.Pale.Bench.Measure + build-depends: + base >= 4.22 && < 5 + , deepseq >= 1.5 && < 1.6 + +test-suite moonlight-pale-bench-measure-test + import: test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: test/bench-measure + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-T + build-depends: + base >= 4.22 && < 5 + , moonlight-pale:measurement + , tasty >= 1.5 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + +library test-surface + import: shared-properties + visibility: public + hs-source-dirs: src-test-surface + exposed-modules: + Moonlight.Pale.Test.ImportDiscipline + Moonlight.Pale.Test.ImportDiscipline.Registry + build-depends: + base >= 4.22 && < 5 + , Cabal-syntax >= 3.16 && < 3.17 + , containers >= 0.8 && < 0.9 + , directory >= 1.3 && < 1.4 + , filepath >= 1.5 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + , text >= 2.1 && < 2.2 + , moonlight-pale:ghc-surface + , moonlight-pale:test + +library test-laws + import: shared-properties + visibility: public + hs-source-dirs: src-test-laws + default-extensions: OverloadedStrings + exposed-modules: + Moonlight.Pale.Test.Laws.Algebraic + Moonlight.Pale.Test.Laws.Lattice + Moonlight.Pale.Test.Laws.Restriction + Moonlight.Pale.Test.Laws.Suite + build-depends: + base >= 4.22 && < 5 + , containers >= 0.8 && < 0.9 + , hedgehog >= 1.7 && < 1.8 + , moonlight-core >= 0.1 && < 0.2 + , tasty >= 1.5 && < 1.6 + , tasty-hedgehog >= 1.4 && < 1.5 + , tasty-hunit >= 0.10 && < 0.11 + , tasty-quickcheck >= 0.11 && < 0.12 + , vector >= 0.13 && < 0.14 + +library diagnostic-ghc + import: shared-properties + visibility: public + hs-source-dirs: src-diagnostic-ghc + exposed-modules: + Moonlight.Pale.TestSupport.CompileDiagnostics + Moonlight.Pale.TestSupport.CompileHieFixture + build-depends: + base >= 4.22 && < 5 + , aeson >= 2.3 && < 2.4 + , bytestring >= 0.12 && < 0.13 + , directory >= 1.3 && < 1.4 + , filepath >= 1.5 && < 1.6 + , moonlight-pale:ghc-surface + , process >= 1.6 && < 1.7 + , temporary >= 1.3 && < 1.4 + , text >= 2.1 && < 2.2 + , moonlight-pale:test + +test-suite moonlight-pale-ghc-surface-test + import: test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: test/ghc-surface + main-is: Main.hs + other-modules: + Hie.OracleSpec + Hie.TypeWordsSpec + ModuleSurfaceSpec + Expr.RenderRoundTripSpec + Expr.SourceCoordinatesSpec + build-depends: + base >= 4.22 && < 5 + , array >= 0.5 && < 0.6 + , bytestring >= 0.12 && < 0.13 + , containers >= 0.8 && < 0.9 + , directory >= 1.3 && < 1.4 + , filepath >= 1.5 && < 1.6 + , ghc >= 9.14 && < 9.16 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-pale:diagnostic-ghc + , moonlight-pale:ghc-surface + , moonlight-pale:test + , process >= 1.6 && < 1.7 + , tasty >= 1.5 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + , text >= 2.1 && < 2.2 + , vector >= 0.13 && < 0.14 + +test-suite moonlight-pale-diagnostic-test + import: test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: test/diagnostic + main-is: Main.hs + other-modules: + WriterSpec + OutcomeSpec + RefinementSpec + CohomologySpec + build-depends: + base >= 4.22 && < 5 + , containers >= 0.8 && < 0.9 + , tasty >= 1.5 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + , moonlight-pale:diagnostic + +test-suite moonlight-pale-test-laws-test + import: test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: test/laws + main-is: Main.hs + default-extensions: OverloadedStrings + other-modules: + AlgebraicSpec + LatticeSpec + RestrictionSpec + SuiteSpec + build-depends: + base >= 4.22 && < 5 + , containers >= 0.8 && < 0.9 + , moonlight-core >= 0.1 && < 0.2 + , tasty >= 1.5 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + , tasty-quickcheck >= 0.11 && < 0.12 + , moonlight-pale:test-laws + +test-suite moonlight-pale-test-support-test + import: test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: test/test-support + main-is: Main.hs + other-modules: + Assertions.AssertionSpec + Recursion.RecursionSpec + Resources.ResourceSpec + build-depends: + base >= 4.22 && < 5 + , containers >= 0.8 && < 0.9 + , hedgehog >= 1.7 && < 1.8 + , tasty >= 1.5 && < 1.6 + , tasty-hedgehog >= 1.4 && < 1.5 + , tasty-hunit >= 0.10 && < 0.11 + , tasty-quickcheck >= 0.11 && < 0.12 + , moonlight-pale:test + +test-suite moonlight-pale-test-surface-test + import: test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: test/import-discipline + main-is: Main.hs + other-modules: + DisciplineSpec + RegistrySpec + build-depends: + base >= 4.22 && < 5 + , containers >= 0.8 && < 0.9 + , tasty >= 1.5 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + , moonlight-pale:test-surface + +test-suite moonlight-pale-diagnostic-ghc-test + import: test-properties + type: exitcode-stdio-1.0 + hs-source-dirs: test/compile-diagnostics + main-is: Main.hs + other-modules: + CompileDiagnosticsSpec + build-depends: + base >= 4.22 && < 5 + , aeson >= 2.3 && < 2.4 + , directory >= 1.3 && < 1.4 + , tasty >= 1.5 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + , moonlight-pale:diagnostic-ghc + , moonlight-pale:test + +common moonlight-pale-benchmark-properties + default-language: GHC2024 + -- Benchmarks are opt-in; their measurement contract requires optimized code. + ghc-options: -Wall -Wcompat -O2 -rtsopts + build-depends: + base >= 4.22 && < 5 + , deepseq >= 1.5 && < 1.6 + , tasty-bench >= 0.5 && < 0.6 + +benchmark moonlight-pale-diagnostic-bench + import: moonlight-pale-benchmark-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/diagnostic + bench/support + main-is: Main.hs + other-modules: + DiagnosticBench + BenchSupport + build-depends: + moonlight-pale:diagnostic + +benchmark moonlight-pale-ghc-surface-bench + import: moonlight-pale-benchmark-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/ghc-surface + bench/support + main-is: Main.hs + other-modules: + GhcSurfaceBench + HieBench + BenchSupport + build-depends: + array >= 0.5 && < 0.6 + , containers >= 0.8 && < 0.9 + , ghc >= 9.14 && < 9.16 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-pale:ghc-surface + , text >= 2.1 && < 2.2 + +benchmark moonlight-pale-laws-bench + import: moonlight-pale-benchmark-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/laws + bench/support + main-is: Main.hs + other-modules: + LawBench + BenchSupport + build-depends: + moonlight-pale:test-laws + +benchmark moonlight-pale-equivalence-receipts + import: moonlight-pale-benchmark-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/receipts + bench/diagnostic + bench/ghc-surface + bench/support + main-is: Main.hs + ghc-options: -threaded -with-rtsopts=-T + other-modules: + DiagnosticBench + GhcSurfaceBench + BenchSupport + build-depends: + moonlight-core >= 0.1 && < 0.2 + , moonlight-pale:diagnostic + , moonlight-pale:ghc-surface + , moonlight-pale:measurement + , text >= 2.1 && < 2.2 + +benchmark moonlight-pale-bench + import: moonlight-pale-benchmark-properties + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/aggregate + bench/diagnostic + bench/ghc-surface + bench/laws + bench/support + main-is: Main.hs + other-modules: + DiagnosticBench + GhcSurfaceBench + HieBench + LawBench + BenchSupport + build-depends: + array >= 0.5 && < 0.6 + , containers >= 0.8 && < 0.9 + , ghc >= 9.14 && < 9.16 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-pale:diagnostic + , moonlight-pale:ghc-surface + , moonlight-pale:test-laws + , text >= 2.1 && < 2.2 + +source-repository head + type: git + location: https://github.com/PaleRoses/moonlight.git + subdir: moonlight-pale diff --git a/src-bench/Moonlight/Pale/Bench/Measure.hs b/src-bench/Moonlight/Pale/Bench/Measure.hs new file mode 100644 --- /dev/null +++ b/src-bench/Moonlight/Pale/Bench/Measure.hs @@ -0,0 +1,463 @@ +{-| Checked wall-clock and RTS-resource measurements for benchmark actions. -} +module Moonlight.Pale.Bench.Measure + ( TimedSample (..), + timeSample, + RtsCounter (..), + RtsSnapshot (..), + RtsDeltaObstruction (..), + RtsDelta (..), + checkedRtsDelta, + RtsPhaseResourceObstruction (..), + RtsPhaseMeasurement, + rtsPhaseElapsedNanoseconds, + measuredRtsPhaseResourceBytes, + RtsPhaseBoundaryObservation (..), + finalizeRtsPhaseMeasurement, + unmeasuredRtsPhaseMeasurement, + combineRtsPhaseMeasurements, + observeRtsPhaseEither, + RtsMeasurementFailure (..), + RtsMeasurement (..), + finalizeRtsMeasurement, + measureSample, + ) +where + +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Data.Bifunctor (first) +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Word (Word32, Word64) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Stats + ( RTSStats, + allocated_bytes, + copied_bytes, + cpu_ns, + elapsed_ns, + gc, + gc_cpu_ns, + gc_elapsed_ns, + gcdetails_live_bytes, + gcs, + getRTSStats, + getRTSStatsEnabled, + major_gcs, + max_live_bytes, + mutator_cpu_ns, + mutator_elapsed_ns, + ) +import System.Mem (performMajorGC) + +data TimedSample value = TimedSample + { timedSampleElapsedNanoseconds :: !Word64, + timedSampleValue :: !value, + timedSampleDigest :: !Int + } + +timeSample :: + Int -> (Int -> IO input) -> (input -> Either errorValue value) -> (value -> Int) -> + IO (Either errorValue (TimedSample value)) +timeSample sampleOrdinal prepareInput runSample digest = do + input <- prepareInput sampleOrdinal + start <- getMonotonicTimeNSec + sampleResult <- evaluate (runSample input) + traverse + ( \sampleValue -> do + sampleDigest <- evaluate (force (digest sampleValue)) + end <- getMonotonicTimeNSec + pure (TimedSample (end - start) sampleValue sampleDigest) + ) + sampleResult + +-- The closed set of monotone RTS counters used by process measurements. +data RtsCounter + = RtsCounterGcs + | RtsCounterMajorGcs + | RtsCounterAllocatedBytes + | RtsCounterCopiedBytes + | RtsCounterMutatorCpuNanoseconds + | RtsCounterMutatorElapsedNanoseconds + | RtsCounterGcCpuNanoseconds + | RtsCounterGcElapsedNanoseconds + | RtsCounterCpuNanoseconds + | RtsCounterElapsedNanoseconds + deriving stock (Eq, Show, Read) + +-- Strict action-boundary projection of the cumulative RTS counters. +data RtsSnapshot = RtsSnapshot + { rtsSnapshotGcs :: !Word32, + rtsSnapshotMajorGcs :: !Word32, + rtsSnapshotAllocatedBytes :: !Word64, + rtsSnapshotCopiedBytes :: !Word64, + rtsSnapshotMutatorCpuNanoseconds :: !Int64, + rtsSnapshotMutatorElapsedNanoseconds :: !Int64, + rtsSnapshotGcCpuNanoseconds :: !Int64, + rtsSnapshotGcElapsedNanoseconds :: !Int64, + rtsSnapshotCpuNanoseconds :: !Int64, + rtsSnapshotElapsedNanoseconds :: !Int64, + rtsSnapshotLiveBytes :: !Word64, + rtsSnapshotMaxLiveBytes :: !Word64 + } + deriving stock (Eq, Show) + +data RtsDeltaObstruction + = RtsCounterRegression !RtsCounter !Integer !Integer + deriving stock (Eq, Show, Read) + +-- Checked action-local differences of every governed cumulative RTS counter. +data RtsDelta = RtsDelta + { rtsDeltaGcs :: !Word64, + rtsDeltaMajorGcs :: !Word64, + rtsDeltaAllocatedBytes :: !Word64, + rtsDeltaCopiedBytes :: !Word64, + rtsDeltaMutatorCpuNanoseconds :: !Word64, + rtsDeltaMutatorElapsedNanoseconds :: !Word64, + rtsDeltaGcCpuNanoseconds :: !Word64, + rtsDeltaGcElapsedNanoseconds :: !Word64, + rtsDeltaCpuNanoseconds :: !Word64, + rtsDeltaElapsedNanoseconds :: !Word64 + } + deriving stock (Eq, Show, Read) + +-- Why a profiled phase cannot publish checked allocation/copy evidence. +-- The semantic action may still succeed: this obstruction belongs to the +-- measurement boundary, not to the domain interpreter being observed. +data RtsPhaseResourceObstruction + = RtsPhaseResourcesUnmeasured + | RtsPhaseStatsUnavailable + | RtsPhaseDeltaRefused !(NonEmpty RtsDeltaObstruction) + deriving stock (Eq, Show, Read) + +data RtsPhaseResources + = RtsPhaseResourcesMeasured + !Integer + !Integer + | RtsPhaseResourcesNotMeasured + | RtsPhaseResourcesStatsUnavailable + | RtsPhaseResourcesDeltaRefused !(NonEmpty RtsDeltaObstruction) + deriving stock (Eq, Show, Read) + +-- One semantic phase observed at its existing IO interpreter boundary. +-- Allocation and copied bytes are checked monotone deltas. They use +-- 'Integer' after differencing so composing adjacent sub-phases is exact and +-- cannot overflow a machine counter type. +data RtsPhaseMeasurement = RtsPhaseMeasurement + { rtsPhaseElapsedNanoseconds :: !Integer, + rtsPhaseResources :: !RtsPhaseResources + } + deriving stock (Eq, Show, Read) + +-- The exhaustive boundary evidence from which a phase measurement is +-- finalized. Snapshot construction remains owned by the RTS interpreter; +-- the pure finalizer makes precedence and checked differencing testable. +data RtsPhaseBoundaryObservation + = RtsPhaseBoundaryNotMeasured + | RtsPhaseBoundaryStatsUnavailable + | RtsPhaseBoundarySnapshots !RtsSnapshot !RtsSnapshot !RtsSnapshot + deriving stock (Eq, Show) + +finalizeRtsPhaseMeasurement :: + Integer -> + RtsPhaseBoundaryObservation -> + RtsPhaseMeasurement +finalizeRtsPhaseMeasurement elapsedNanoseconds boundaryObservation = + RtsPhaseMeasurement + { rtsPhaseElapsedNanoseconds = elapsedNanoseconds, + rtsPhaseResources = + case boundaryObservation of + RtsPhaseBoundaryNotMeasured -> RtsPhaseResourcesNotMeasured + RtsPhaseBoundaryStatsUnavailable -> RtsPhaseResourcesStatsUnavailable + RtsPhaseBoundarySnapshots beforeAction afterAction afterPostGc -> + either + (RtsPhaseResourcesDeltaRefused . (:| [])) + ( \deltaValue -> + RtsPhaseResourcesMeasured + (toInteger (rtsDeltaAllocatedBytes deltaValue)) + (toInteger (rtsDeltaCopiedBytes deltaValue)) + ) + (checkedRtsPhaseDelta beforeAction afterAction afterPostGc) + } + +measuredRtsPhaseResourceBytes :: + RtsPhaseMeasurement -> + Either RtsPhaseResourceObstruction (Integer, Integer) +measuredRtsPhaseResourceBytes measurementValue = + case rtsPhaseResources measurementValue of + RtsPhaseResourcesMeasured allocatedBytes copiedBytes -> + Right (allocatedBytes, copiedBytes) + RtsPhaseResourcesNotMeasured -> Left RtsPhaseResourcesUnmeasured + RtsPhaseResourcesStatsUnavailable -> Left RtsPhaseStatsUnavailable + RtsPhaseResourcesDeltaRefused obstructions -> + Left (RtsPhaseDeltaRefused obstructions) + +unmeasuredRtsPhaseMeasurement :: RtsPhaseMeasurement +unmeasuredRtsPhaseMeasurement = + finalizeRtsPhaseMeasurement 0 RtsPhaseBoundaryNotMeasured + +combineRtsPhaseMeasurements :: + RtsPhaseMeasurement -> + RtsPhaseMeasurement -> + RtsPhaseMeasurement +combineRtsPhaseMeasurements leftMeasurement rightMeasurement = + RtsPhaseMeasurement + { rtsPhaseElapsedNanoseconds = + rtsPhaseElapsedNanoseconds leftMeasurement + + rtsPhaseElapsedNanoseconds rightMeasurement, + rtsPhaseResources = + combineRtsPhaseResources + (rtsPhaseResources leftMeasurement) + (rtsPhaseResources rightMeasurement) + } + +combineRtsPhaseResources :: + RtsPhaseResources -> + RtsPhaseResources -> + RtsPhaseResources +combineRtsPhaseResources leftResources rightResources = + case (leftResources, rightResources) of + (RtsPhaseResourcesDeltaRefused leftObstructions, RtsPhaseResourcesDeltaRefused rightObstructions) -> + RtsPhaseResourcesDeltaRefused (leftObstructions <> rightObstructions) + (RtsPhaseResourcesDeltaRefused obstructions, _) -> + RtsPhaseResourcesDeltaRefused obstructions + (_, RtsPhaseResourcesDeltaRefused obstructions) -> + RtsPhaseResourcesDeltaRefused obstructions + (RtsPhaseResourcesStatsUnavailable, _) -> RtsPhaseResourcesStatsUnavailable + (_, RtsPhaseResourcesStatsUnavailable) -> RtsPhaseResourcesStatsUnavailable + (RtsPhaseResourcesNotMeasured, _) -> RtsPhaseResourcesNotMeasured + (_, RtsPhaseResourcesNotMeasured) -> RtsPhaseResourcesNotMeasured + (RtsPhaseResourcesMeasured leftAllocated leftCopied, RtsPhaseResourcesMeasured rightAllocated rightCopied) -> + RtsPhaseResourcesMeasured + (leftAllocated + rightAllocated) + (leftCopied + rightCopied) + +-- Observe one already-owned pure phase without introducing a second +-- pipeline. A major collection before the phase establishes the allocation +-- boundary; the post-phase collection closes the nursery for allocation only. +-- Copied bytes and elapsed time stop before that collection, matching +-- 'finalizeRtsMeasurement'. Neither boundary collection is charged to phase +-- elapsed time. +observeRtsPhaseEither :: + (value -> witness) -> + Either errorValue value -> + IO (Either errorValue (value, RtsPhaseMeasurement)) +observeRtsPhaseEither timingReadiness phaseResult = + getRTSStatsEnabled >>= \statsEnabled -> + if statsEnabled + then observeWithStats + else observeWithoutStats + where + observeWithStats = do + beforeActionStats <- majorGcStats + start <- getMonotonicTimeNSec + case phaseResult of + Left phaseFailure -> pure (Left phaseFailure) + Right phaseValue -> do + _ <- evaluate (timingReadiness phaseValue) + end <- getMonotonicTimeNSec + afterActionStats <- getRTSStats + afterPostGcStats <- majorGcStats + pure + ( Right + ( phaseValue, + finalizeRtsPhaseMeasurement + (toInteger (end - start)) + ( RtsPhaseBoundarySnapshots + (rtsSnapshotFromStats beforeActionStats) + (rtsSnapshotFromStats afterActionStats) + (rtsSnapshotFromStats afterPostGcStats) + ) + ) + ) + + observeWithoutStats = do + start <- getMonotonicTimeNSec + case phaseResult of + Left phaseFailure -> pure (Left phaseFailure) + Right phaseValue -> do + _ <- evaluate (timingReadiness phaseValue) + end <- getMonotonicTimeNSec + pure + ( Right + ( phaseValue, + finalizeRtsPhaseMeasurement + (toInteger (end - start)) + RtsPhaseBoundaryStatsUnavailable + ) + ) + +checkedRtsPhaseDelta :: + RtsSnapshot -> + RtsSnapshot -> + RtsSnapshot -> + Either RtsDeltaObstruction RtsDelta +checkedRtsPhaseDelta beforeAction afterAction afterPostGc = + (\actionDelta allocatedBytes -> actionDelta {rtsDeltaAllocatedBytes = allocatedBytes}) + <$> checkedRtsDelta beforeAction afterAction + <*> checkedCounterDifference + RtsCounterAllocatedBytes + (rtsSnapshotAllocatedBytes beforeAction) + (rtsSnapshotAllocatedBytes afterPostGc) + +checkedRtsDelta :: + RtsSnapshot -> + RtsSnapshot -> + Either RtsDeltaObstruction RtsDelta +checkedRtsDelta beforeSnapshot afterSnapshot = + RtsDelta + <$> counterDelta RtsCounterGcs rtsSnapshotGcs + <*> counterDelta RtsCounterMajorGcs rtsSnapshotMajorGcs + <*> counterDelta RtsCounterAllocatedBytes rtsSnapshotAllocatedBytes + <*> counterDelta RtsCounterCopiedBytes rtsSnapshotCopiedBytes + <*> counterDelta RtsCounterMutatorCpuNanoseconds rtsSnapshotMutatorCpuNanoseconds + <*> counterDelta RtsCounterMutatorElapsedNanoseconds rtsSnapshotMutatorElapsedNanoseconds + <*> counterDelta RtsCounterGcCpuNanoseconds rtsSnapshotGcCpuNanoseconds + <*> counterDelta RtsCounterGcElapsedNanoseconds rtsSnapshotGcElapsedNanoseconds + <*> counterDelta RtsCounterCpuNanoseconds rtsSnapshotCpuNanoseconds + <*> counterDelta RtsCounterElapsedNanoseconds rtsSnapshotElapsedNanoseconds + where + counterDelta :: + (Integral counter) => + RtsCounter -> + (RtsSnapshot -> counter) -> + Either RtsDeltaObstruction Word64 + counterDelta counter project = + checkedCounterDifference counter (project beforeSnapshot) (project afterSnapshot) + +checkedCounterDifference :: + (Integral counter) => + RtsCounter -> + counter -> + counter -> + Either RtsDeltaObstruction Word64 +checkedCounterDifference counter beforeValue afterValue + | afterValue < beforeValue = + Left + ( RtsCounterRegression + counter + (toInteger beforeValue) + (toInteger afterValue) + ) + | otherwise = + Right (fromIntegral (afterValue - beforeValue)) + +data RtsMeasurementFailure errorValue + = RtsMeasurementStatsDisabled + | RtsMeasurementActionFailed !errorValue + | RtsMeasurementDeltaFailed !RtsDeltaObstruction + deriving stock (Eq, Show) + +data RtsMeasurement value = RtsMeasurement + { rtsMeasurementElapsedNanoseconds :: !Word64, + rtsMeasurementDelta :: !RtsDelta, + rtsMeasurementProcessLiveBytesAfterGc :: !Word64, + rtsMeasurementProcessMaxLiveBytes :: !Word64, + rtsMeasurementValue :: !value, + rtsMeasurementDigest :: !Int + } + +-- Pure checked gluing of the three action-boundary RTS observations. +-- The live and maximum fields are explicitly process-wide observations. GHC's +-- counters do not expose action-local retained or peak residency. +-- +-- Allocation is taken across the post-GC boundary while every other counter is +-- taken across the action boundary, and the asymmetry is deliberate. GHC +-- refreshes @allocated_bytes@ at garbage collections, so a plain +-- before-to-after difference counts only the allocation that a collection +-- inside the region happened to close out: measured 2026-08-06, four of five +-- atomic probes reported exactly zero allocated bytes beside a nonzero wall, +-- each with a zero GC count, while the one probe that triggered four +-- collections reported 17.7 MB. Reading allocation after a major collection +-- accounts the outstanding nursery. It is sound for this counter alone because +-- a collection performs no mutator allocation; the timing counters and +-- @copied_bytes@ must not cross that boundary, since the collection's own cost +-- would be attributed to the measured action. +finalizeRtsMeasurement :: + Word64 -> + RtsSnapshot -> + RtsSnapshot -> + RtsSnapshot -> + value -> + Int -> + Either RtsDeltaObstruction (RtsMeasurement value) +finalizeRtsMeasurement elapsedNanoseconds beforeAction afterAction afterPostGc sampleValue sampleDigest = + (\actionDelta allocatedBytes -> + RtsMeasurement + { rtsMeasurementElapsedNanoseconds = elapsedNanoseconds, + rtsMeasurementDelta = actionDelta {rtsDeltaAllocatedBytes = allocatedBytes}, + rtsMeasurementProcessLiveBytesAfterGc = rtsSnapshotLiveBytes afterPostGc, + rtsMeasurementProcessMaxLiveBytes = rtsSnapshotMaxLiveBytes afterPostGc, + rtsMeasurementValue = sampleValue, + rtsMeasurementDigest = sampleDigest + } + ) + <$> checkedRtsDelta beforeAction afterAction + <*> checkedCounterDifference + RtsCounterAllocatedBytes + (rtsSnapshotAllocatedBytes beforeAction) + (rtsSnapshotAllocatedBytes afterPostGc) + +measureSample :: + Int -> + (Int -> IO input) -> + (input -> IO (Either errorValue value)) -> + (value -> ()) -> + (value -> Int) -> + IO (Either (RtsMeasurementFailure errorValue) (RtsMeasurement value)) +measureSample sampleOrdinal prepareInput runSample timingReadiness digest = + getRTSStatsEnabled >>= \statsEnabled -> + if statsEnabled + then measureWithStats + else pure (Left RtsMeasurementStatsDisabled) + where + measureWithStats = do + input <- prepareInput sampleOrdinal + beforeActionStats <- majorGcStats + start <- getMonotonicTimeNSec + sampleResult <- runSample input + fmap (>>= id) $ + traverse + (finishMeasurement beforeActionStats start) + (first RtsMeasurementActionFailed sampleResult) + + finishMeasurement beforeActionStats start sampleValue = do + sampleDigest <- + snd + <$> evaluate + (force (timingReadiness sampleValue, digest sampleValue)) + end <- getMonotonicTimeNSec + afterActionStats <- getRTSStats + afterPostGcStats <- majorGcStats + pure + ( first RtsMeasurementDeltaFailed + ( finalizeRtsMeasurement + (end - start) + (rtsSnapshotFromStats beforeActionStats) + (rtsSnapshotFromStats afterActionStats) + (rtsSnapshotFromStats afterPostGcStats) + sampleValue + sampleDigest + ) + ) + +rtsSnapshotFromStats :: RTSStats -> RtsSnapshot +rtsSnapshotFromStats stats = + RtsSnapshot + { rtsSnapshotGcs = gcs stats, + rtsSnapshotMajorGcs = major_gcs stats, + rtsSnapshotAllocatedBytes = allocated_bytes stats, + rtsSnapshotCopiedBytes = copied_bytes stats, + rtsSnapshotMutatorCpuNanoseconds = mutator_cpu_ns stats, + rtsSnapshotMutatorElapsedNanoseconds = mutator_elapsed_ns stats, + rtsSnapshotGcCpuNanoseconds = gc_cpu_ns stats, + rtsSnapshotGcElapsedNanoseconds = gc_elapsed_ns stats, + rtsSnapshotCpuNanoseconds = cpu_ns stats, + rtsSnapshotElapsedNanoseconds = elapsed_ns stats, + rtsSnapshotLiveBytes = gcdetails_live_bytes (gc stats), + rtsSnapshotMaxLiveBytes = max_live_bytes stats + } + +majorGcStats :: IO RTSStats +majorGcStats = + performMajorGC *> getRTSStats diff --git a/src-diagnostic-ghc/Moonlight/Pale/TestSupport/CompileDiagnostics.hs b/src-diagnostic-ghc/Moonlight/Pale/TestSupport/CompileDiagnostics.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic-ghc/Moonlight/Pale/TestSupport/CompileDiagnostics.hs @@ -0,0 +1,756 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| Typed GHC diagnostic capture, normalization, and snapshot persistence for tests. -} +module Moonlight.Pale.TestSupport.CompileDiagnostics + ( SnapshotExit (..), + DiagnosticsFlag (..), + DiagnosticsFlagSelectionFailure (..), + DiagnosticStream (..), + DiagnosticParseFailureReason (..), + DiagnosticParseFailure (..), + CompileFixtureFailure (..), + UnstructuredCompileFailure (..), + ProcessInvocationFailure (..), + SnapshotFileFailure (..), + GhcPackageSpec (..), + NormalizedDiagnostic (..), + DiagnosticSnapshot (..), + FixtureCompileResult (..), + CompileDiagnosticsSession, + CompileSessionFailure (..), + openCompileDiagnosticsSession, + compileFixtures, + normalizeSnapshot, + readSnapshot, + writeSnapshot, + snapshotRefreshEnabled, + renderSnapshotFileFailure, + renderFixtureFailure, + ResourcePath.ResourcePathError (..), + ResourcePath.renderResourcePathError, + resolveCompilerRoot, + ) +where + +import Control.Applicative ((<|>)) +import Control.Exception + ( SomeAsyncException, + SomeException, + displayException, + fromException, + throwIO, + try, + ) +import Control.Monad (join) +import Data.Bifunctor (first) +import Data.Aeson + ( FromJSON (..), + Object, + Value (..), + ToJSON (..), + eitherDecodeStrict', + encode, + object, + withObject, + withText, + (.:), + (.:?), + (.=), + ) +import Data.Aeson.KeyMap qualified as KeyMap +import qualified Data.Aeson.Key as Key +import Data.Aeson.Types (Parser, parseEither) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as ByteStringChar8 +import qualified Data.ByteString.Lazy as LazyByteString +import Data.Char (isSpace) +import Data.Kind (Type) +import Data.List (find, sort) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Moonlight.Pale.Test.Resources as ResourcePath +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.FilePath (makeRelative, normalise, takeDirectory) +import System.Process (CreateProcess (cwd), proc, readCreateProcessWithExitCode) + +type SnapshotExit :: Type +data SnapshotExit + = SnapshotSuccess + | SnapshotFailure + deriving stock (Eq, Show) + +type GhcPackageSpec :: Type +data GhcPackageSpec + = GhcPackageName !String + | GhcPackageId !String + deriving stock (Eq, Show) + +type DiagnosticsFlag :: Type +data DiagnosticsFlag + = DiagnosticsAsJson + | DiagnosticsJson + | DumpJson + deriving stock (Bounded, Enum, Eq, Show) + +type DiagnosticsFlagSelectionFailure :: Type +data DiagnosticsFlagSelectionFailure = DiagnosticsFlagSelectionFailure + { diagnosticsFlagSelectionExitCode :: !ExitCode, + diagnosticsFlagSelectionObservedOptions :: ![String] + } + deriving stock (Eq, Show) + +type CompileSessionFailure :: Type +data CompileSessionFailure + = CompileSessionDiagnosticsFlagSelectionFailed !DiagnosticsFlagSelectionFailure + | CompileSessionResourceDiscoveryFailed !ResourcePath.ResourcePathError + | CompileSessionProcessInvocationFailed !ProcessInvocationFailure + deriving stock (Eq, Show) + +type ProcessInvocationFailure :: Type +data ProcessInvocationFailure = ProcessInvocationFailure + { processInvocationCommand :: !FilePath, + processInvocationArguments :: ![String], + processInvocationException :: !String + } + deriving stock (Eq, Show) + +type CompileDiagnosticsSession :: Type +data CompileDiagnosticsSession = CompileDiagnosticsSession + { cdsCompilerRoot :: !FilePath, + cdsBuildDirectory :: !(Maybe FilePath), + cdsDiagnosticsFlag :: !DiagnosticsFlag + } + deriving stock (Eq, Show) + +type DiagnosticStream :: Type +data DiagnosticStream + = DiagnosticStdout + | DiagnosticStderr + deriving stock (Eq, Show) + +type DiagnosticParseFailureReason :: Type +data DiagnosticParseFailureReason + = DiagnosticLineMalformedJson !String + | DiagnosticLineMalformedPayload !String + deriving stock (Eq, Show) + +type DiagnosticParseFailure :: Type +data DiagnosticParseFailure = DiagnosticParseFailure + { diagnosticParseFailureStream :: !DiagnosticStream, + diagnosticParseFailureLineNumber :: !Int, + diagnosticParseFailureLine :: !String, + diagnosticParseFailureReason :: !DiagnosticParseFailureReason + } + deriving stock (Eq, Show) + +type CompileFixtureFailure :: Type +data CompileFixtureFailure + = CompileFixtureDiagnosticParseFailed ![DiagnosticParseFailure] + | CompileFixtureUnstructuredFailure !UnstructuredCompileFailure + | CompileFixtureProcessInvocationFailed !ProcessInvocationFailure + deriving stock (Eq, Show) + +type UnstructuredCompileFailure :: Type +data UnstructuredCompileFailure = UnstructuredCompileFailure + { unstructuredCompileExitCode :: !ExitCode, + unstructuredCompileStdout :: !String, + unstructuredCompileStderr :: !String + } + deriving stock (Eq, Show) + +type DiagnosticParseResult :: Type +data DiagnosticParseResult = DiagnosticParseResult + { diagnosticParseResultFailures :: ![DiagnosticParseFailure], + diagnosticParseResultDiagnostics :: ![GhcDiagnostic] + } + deriving stock (Eq, Show) + +type DiagnosticPayloadKey :: Type +data DiagnosticPayloadKey + = DiagnosticPayloadMessageClass + | DiagnosticPayloadSeverity + | DiagnosticPayloadSpan + | DiagnosticPayloadCode + | DiagnosticPayloadReason + | DiagnosticPayloadDoc + deriving stock (Bounded, Enum, Eq, Show) + +instance Semigroup DiagnosticParseResult where + leftResult <> rightResult = + DiagnosticParseResult + { diagnosticParseResultFailures = + diagnosticParseResultFailures leftResult + <> diagnosticParseResultFailures rightResult, + diagnosticParseResultDiagnostics = + diagnosticParseResultDiagnostics leftResult + <> diagnosticParseResultDiagnostics rightResult + } + +instance Monoid DiagnosticParseResult where + mempty = + DiagnosticParseResult + { diagnosticParseResultFailures = [], + diagnosticParseResultDiagnostics = [] + } + +instance FromJSON SnapshotExit where + parseJSON = + withText "SnapshotExit" $ \value -> + case value of + "success" -> pure SnapshotSuccess + "failure" -> pure SnapshotFailure + _ -> fail ("unsupported snapshot exit value: " <> Text.unpack value) + +instance ToJSON SnapshotExit where + toJSON snapshotExitValue = + case snapshotExitValue of + SnapshotSuccess -> "success" + SnapshotFailure -> "failure" + +type DiagnosticSpan :: Type +data DiagnosticSpan = DiagnosticSpan + { spanFile :: !FilePath, + spanStartLine :: !Int, + spanStartCol :: !Int, + spanEndLine :: !Int, + spanEndCol :: !Int + } + deriving stock (Eq, Show) + +instance FromJSON DiagnosticSpan where + parseJSON = + withObject "DiagnosticSpan" $ \diagnosticObject -> + do + spanFilePath <- diagnosticObject .: "file" + startLineValue <- coordinateValue diagnosticObject "startLine" "start" "line" + startColValue <- coordinateValue diagnosticObject "startCol" "start" "column" + endLineValue <- coordinateValue diagnosticObject "endLine" "end" "line" + endColValue <- coordinateValue diagnosticObject "endCol" "end" "column" + pure + DiagnosticSpan + { spanFile = spanFilePath, + spanStartLine = startLineValue, + spanStartCol = startColValue, + spanEndLine = endLineValue, + spanEndCol = endColValue + } + where + coordinateValue :: + FromJSON coordinate => + Object -> + Key.Key -> + Key.Key -> + Key.Key -> + Parser coordinate + coordinateValue diagnosticObject flatKey positionKey coordinateKey = do + flatValue <- diagnosticObject .:? flatKey + case flatValue of + Just value -> pure value + Nothing -> diagnosticObject .: positionKey >>= (.: coordinateKey) + +type GhcDiagnostic :: Type +data GhcDiagnostic = GhcDiagnostic + { diagnosticSpan :: !(Maybe DiagnosticSpan), + diagnosticClass :: !Text, + diagnosticSeverity :: !(Maybe Text), + diagnosticCodeText :: !(Maybe Text) + } + deriving stock (Eq, Show) + +instance FromJSON GhcDiagnostic where + parseJSON = + withObject "GhcDiagnostic" $ \diagnosticObject -> + do + messageClassValue <- diagnosticObject .:? "messageClass" + severityValue <- diagnosticObject .:? "severity" + spanValue <- diagnosticObject .:? "span" + rawCodeValue <- diagnosticObject .:? "code" :: Parser (Maybe Value) + let codeValue = + rawCodeValue >>= \codeValue' -> + case codeValue' of + String textValue -> Just ("GHC-" <> textValue) + Number numericValue -> + Just + ( "GHC-" + <> Text.takeWhile (/= '.') (Text.pack (show numericValue)) + ) + _ -> Nothing + pure + GhcDiagnostic + { diagnosticSpan = spanValue, + diagnosticClass = fromMaybe "" messageClassValue, + diagnosticSeverity = severityValue, + diagnosticCodeText = codeValue + } + +type NormalizedDiagnostic :: Type +data NormalizedDiagnostic = NormalizedDiagnostic + { normalizedCode :: !Text, + normalizedFile :: !FilePath, + normalizedStartLine :: !Int, + normalizedStartCol :: !Int, + normalizedEndLine :: !Int, + normalizedEndCol :: !Int + } + deriving stock (Eq, Ord, Show) + +instance FromJSON NormalizedDiagnostic where + parseJSON = + withObject "NormalizedDiagnostic" $ \diagnosticObject -> + NormalizedDiagnostic + <$> diagnosticObject .: "code" + <*> diagnosticObject .: "file" + <*> diagnosticObject .: "startLine" + <*> diagnosticObject .: "startCol" + <*> diagnosticObject .: "endLine" + <*> diagnosticObject .: "endCol" + +instance ToJSON NormalizedDiagnostic where + toJSON normalizedDiagnostic = + object + [ "code" .= normalizedCode normalizedDiagnostic, + "file" .= normalizedFile normalizedDiagnostic, + "startLine" .= normalizedStartLine normalizedDiagnostic, + "startCol" .= normalizedStartCol normalizedDiagnostic, + "endLine" .= normalizedEndLine normalizedDiagnostic, + "endCol" .= normalizedEndCol normalizedDiagnostic + ] + +type DiagnosticSnapshot :: Type +data DiagnosticSnapshot = DiagnosticSnapshot + { snapshotFixture :: !FilePath, + snapshotDiagnosticsFlag :: !String, + snapshotExit :: !SnapshotExit, + snapshotDiagnostics :: ![NormalizedDiagnostic] + } + deriving stock (Eq, Show) + +type SnapshotFileFailure :: Type +data SnapshotFileFailure + = SnapshotFileMissing !FilePath + | SnapshotDecodeFailed !FilePath !String + | SnapshotFilesystemFailed !FilePath !String + deriving stock (Eq, Show) + +instance FromJSON DiagnosticSnapshot where + parseJSON = + withObject "DiagnosticSnapshot" $ \diagnosticObject -> + DiagnosticSnapshot + <$> diagnosticObject .: "fixture" + <*> diagnosticObject .: "diagnosticsFlag" + <*> diagnosticObject .: "exit" + <*> (sort <$> diagnosticObject .: "diagnostics") + +instance ToJSON DiagnosticSnapshot where + toJSON diagnosticSnapshot = + object + [ "fixture" .= snapshotFixture diagnosticSnapshot, + "diagnosticsFlag" .= snapshotDiagnosticsFlag diagnosticSnapshot, + "exit" .= snapshotExit diagnosticSnapshot, + "diagnostics" .= sort (snapshotDiagnostics diagnosticSnapshot) + ] + +type FixtureCompileResult :: Type +data FixtureCompileResult = FixtureCompileResult + { fixtureExitCode :: !ExitCode, + fixtureStdout :: !String, + fixtureStderr :: !String, + fixtureDiagnostics :: ![GhcDiagnostic], + diagnosticsFlag :: !DiagnosticsFlag + } + deriving stock (Eq, Show) + +openCompileDiagnosticsSession :: + FilePath -> + IO (Either CompileSessionFailure CompileDiagnosticsSession) +openCompileDiagnosticsSession compilerRoot = do + buildDirectoryResult <- ResourcePath.findActiveCabalBuildDirectory + case buildDirectoryResult of + Left resourceFailure -> + pure (Left (CompileSessionResourceDiscoveryFailed resourceFailure)) + Right buildDirectory -> do + let cabalArguments = + diagnosticsFlagArguments buildDirectory + diagnosticsFlagIoResult <- + trySynchronous + (processInvocationFailure "cabal" cabalArguments) + (resolveDiagnosticsFlagWithBuildDirectory buildDirectory compilerRoot) + pure + ( case diagnosticsFlagIoResult of + Left processFailure -> + Left (CompileSessionProcessInvocationFailed processFailure) + Right diagnosticsFlagResult -> + first + CompileSessionDiagnosticsFlagSelectionFailed + ( fmap + (CompileDiagnosticsSession compilerRoot buildDirectory) + diagnosticsFlagResult + ) + ) + +compileFixtures :: + CompileDiagnosticsSession -> + [GhcPackageSpec] -> + NonEmpty FilePath -> + IO (Either CompileFixtureFailure FixtureCompileResult) +compileFixtures session packageSpecs fixturePaths = do + let selectedFlag = cdsDiagnosticsFlag session + compilerRoot = cdsCompilerRoot session + cabalArguments = + cabalArgumentsForBuildDirectory + (cdsBuildDirectory session) + (ghcInvocation packageSpecs selectedFlag (NonEmpty.toList fixturePaths)) + processResult <- + trySynchronous + (processInvocationFailure "cabal" cabalArguments) + ( readCreateProcessWithExitCode + ( (proc "cabal" cabalArguments) + {cwd = Just compilerRoot} + ) + "" + ) + pure + ( case processResult of + Left processFailure -> + Left (CompileFixtureProcessInvocationFailed processFailure) + Right (exitCode, stdoutText, stderrText) -> + case diagnosticParseResultEither + ( parseDiagnostics DiagnosticStdout stdoutText + <> parseDiagnostics DiagnosticStderr stderrText + ) of + Left parseFailures -> + Left (CompileFixtureDiagnosticParseFailed parseFailures) + Right diagnostics + | ExitFailure _ <- exitCode, + null (normalizeErrorDiagnostics compilerRoot diagnostics) -> + Left + ( CompileFixtureUnstructuredFailure + UnstructuredCompileFailure + { unstructuredCompileExitCode = exitCode, + unstructuredCompileStdout = stdoutText, + unstructuredCompileStderr = stderrText + } + ) + Right diagnostics -> + Right + FixtureCompileResult + { fixtureExitCode = exitCode, + fixtureStdout = stdoutText, + fixtureStderr = stderrText, + fixtureDiagnostics = diagnostics, + diagnosticsFlag = selectedFlag + } + ) + +-- A snapshot names one fixture, so diagnostics from the other fixtures of a +-- multi-fixture invocation are not part of it. The scoping is a no-op for a +-- singleton invocation; it is what makes a batched one attributable. +normalizeSnapshot :: FilePath -> FilePath -> FixtureCompileResult -> DiagnosticSnapshot +normalizeSnapshot compilerRoot fixtureRelativePath' result = + DiagnosticSnapshot + { snapshotFixture = normalizedFixture, + snapshotDiagnosticsFlag = diagnosticsFlagArgument (diagnosticsFlag result), + snapshotExit = toSnapshotExit (fixtureExitCode result), + snapshotDiagnostics = + filter + ((== normalizedFixture) . normalizedFile) + (normalizeErrorDiagnostics compilerRoot (fixtureDiagnostics result)) + } + where + normalizedFixture = normalizeRelativePath fixtureRelativePath' + +readSnapshot :: FilePath -> IO (Either SnapshotFileFailure DiagnosticSnapshot) +readSnapshot snapshotPath = + fmap join $ + trySynchronous + (SnapshotFilesystemFailed snapshotPath . displayException) + ( do + exists <- doesFileExist snapshotPath + if exists + then do + payload <- ByteString.readFile snapshotPath + pure + ( first + (SnapshotDecodeFailed snapshotPath) + (eitherDecodeStrict' payload) + ) + else + pure (Left (SnapshotFileMissing snapshotPath)) + ) + +writeSnapshot :: + FilePath -> + DiagnosticSnapshot -> + IO (Either SnapshotFileFailure ()) +writeSnapshot snapshotPath snapshot = + trySynchronous + (SnapshotFilesystemFailed snapshotPath . displayException) + ( do + createDirectoryIfMissing True (takeDirectory snapshotPath) + LazyByteString.writeFile snapshotPath (encode snapshot) + ) + +snapshotRefreshEnabled :: IO (Either SnapshotFileFailure Bool) +snapshotRefreshEnabled = + trySynchronous + (SnapshotFilesystemFailed "UPDATE_SNAPSHOTS" . displayException) + ((== Just "1") <$> lookupEnv "UPDATE_SNAPSHOTS") + +renderSnapshotFileFailure :: SnapshotFileFailure -> String +renderSnapshotFileFailure = \case + SnapshotFileMissing snapshotPath -> + "missing snapshot file: " <> snapshotPath + SnapshotDecodeFailed snapshotPath decodeError -> + "failed to decode snapshot file: " <> snapshotPath <> "\n" <> decodeError + SnapshotFilesystemFailed snapshotPath exceptionText -> + "snapshot filesystem failure at " <> snapshotPath <> ": " <> exceptionText + +renderFixtureFailure :: FixtureCompileResult -> String +renderFixtureFailure result = + "diagnostics flag: " + <> diagnosticsFlagArgument (diagnosticsFlag result) + <> "\nstdout:\n" + <> fixtureStdout result + <> "\nstderr:\n" + <> fixtureStderr result + +resolveCompilerRoot :: + FilePath -> + IO (Either ResourcePath.ResourcePathError FilePath) +resolveCompilerRoot = ResourcePath.resolveCompilerRoot + +diagnosticsFlagArgument :: DiagnosticsFlag -> String +diagnosticsFlagArgument selectedFlag = + case selectedFlag of + DiagnosticsAsJson -> "-fdiagnostics-as-json" + DiagnosticsJson -> "-fdiagnostics-json" + DumpJson -> "-ddump-json" + +ghcInvocation :: [GhcPackageSpec] -> DiagnosticsFlag -> [FilePath] -> [String] +ghcInvocation packageSpecs selectedFlag fixturePaths = + [ "exec", + "--", + "ghc", + "-fforce-recomp", + "-fno-code" + ] + <> concatMap renderGhcPackageSpec packageSpecs + <> [diagnosticsFlagArgument selectedFlag] + <> fixturePaths + +renderGhcPackageSpec :: GhcPackageSpec -> [String] +renderGhcPackageSpec packageSpec = + case packageSpec of + GhcPackageName packageName -> + ["-package", packageName] + GhcPackageId packageId -> + ["-package-id", packageId] + +resolveDiagnosticsFlagWithBuildDirectory :: + Maybe FilePath -> + FilePath -> + IO (Either DiagnosticsFlagSelectionFailure DiagnosticsFlag) +resolveDiagnosticsFlagWithBuildDirectory buildDirectory compilerRoot = do + let cabalArguments = diagnosticsFlagArguments buildDirectory + (exitCode, stdoutText, stderrText) <- + readCreateProcessWithExitCode + ((proc "cabal" cabalArguments) {cwd = Just compilerRoot}) + "" + let optionLines = lines stdoutText <> lines stderrText + pure (selectedDiagnosticsFlag exitCode optionLines) + +diagnosticsFlagArguments :: Maybe FilePath -> [String] +diagnosticsFlagArguments buildDirectory = + cabalArgumentsForBuildDirectory + buildDirectory + ["exec", "--", "ghc", "--show-options"] + +processInvocationFailure :: + FilePath -> + [String] -> + SomeException -> + ProcessInvocationFailure +processInvocationFailure commandPath commandArguments exceptionValue = + ProcessInvocationFailure + { processInvocationCommand = commandPath, + processInvocationArguments = commandArguments, + processInvocationException = displayException exceptionValue + } + +trySynchronous :: + (SomeException -> failure) -> + IO value -> + IO (Either failure value) +trySynchronous toFailure action = do + result <- try action + case result of + Left exceptionValue + | Just asyncException <- + (fromException exceptionValue :: Maybe SomeAsyncException) -> + throwIO asyncException + | otherwise -> + pure (Left (toFailure exceptionValue)) + Right value -> + pure (Right value) + +selectedDiagnosticsFlag :: + ExitCode -> + [String] -> + Either DiagnosticsFlagSelectionFailure DiagnosticsFlag +selectedDiagnosticsFlag exitCode optionLines = + case find (`diagnosticsFlagIsObservedIn` optionLines) diagnosticsFlagPriority of + Just selectedFlag -> Right selectedFlag + Nothing -> + Left + DiagnosticsFlagSelectionFailure + { diagnosticsFlagSelectionExitCode = exitCode, + diagnosticsFlagSelectionObservedOptions = optionLines + } + +diagnosticsFlagPriority :: [DiagnosticsFlag] +diagnosticsFlagPriority = [minBound .. maxBound] + +diagnosticsFlagIsObservedIn :: DiagnosticsFlag -> [String] -> Bool +diagnosticsFlagIsObservedIn selectedFlag optionLines = + diagnosticsFlagArgument selectedFlag `elem` optionLines + +cabalArgumentsForBuildDirectory :: Maybe FilePath -> [String] -> [String] +cabalArgumentsForBuildDirectory maybeBuildDirectory commandArguments = + maybe + commandArguments + (\buildDirectory -> ("--builddir=" <> buildDirectory) : commandArguments) + maybeBuildDirectory + +parseDiagnostics :: DiagnosticStream -> String -> DiagnosticParseResult +parseDiagnostics streamName = + foldMap (decodeDiagnosticLine streamName) + . zip [1 ..] + . lines + +diagnosticParseResultEither :: DiagnosticParseResult -> Either [DiagnosticParseFailure] [GhcDiagnostic] +diagnosticParseResultEither result = + case diagnosticParseResultFailures result of + [] -> Right (diagnosticParseResultDiagnostics result) + parseFailures -> Left parseFailures + +decodeDiagnosticLine :: DiagnosticStream -> (Int, String) -> DiagnosticParseResult +decodeDiagnosticLine streamName (lineNumber, line) = + case eitherDecodeStrict' (ByteStringChar8.pack line) of + Left jsonError -> + if looksLikeJsonObjectLine line + then diagnosticLineFailure streamName lineNumber line (DiagnosticLineMalformedJson jsonError) + else mempty + Right value -> + if looksLikeDiagnosticValue value + then decodeDiagnosticPayload streamName lineNumber line value + else mempty + +decodeDiagnosticPayload :: DiagnosticStream -> Int -> String -> Value -> DiagnosticParseResult +decodeDiagnosticPayload streamName lineNumber line value = + case parseEither parseJSON value of + Left payloadError -> + diagnosticLineFailure streamName lineNumber line (DiagnosticLineMalformedPayload payloadError) + Right diagnostic -> + diagnosticLineSuccess diagnostic + +diagnosticLineFailure :: + DiagnosticStream -> + Int -> + String -> + DiagnosticParseFailureReason -> + DiagnosticParseResult +diagnosticLineFailure streamName lineNumber line reason = + DiagnosticParseResult + { diagnosticParseResultFailures = + [ DiagnosticParseFailure + { diagnosticParseFailureStream = streamName, + diagnosticParseFailureLineNumber = lineNumber, + diagnosticParseFailureLine = line, + diagnosticParseFailureReason = reason + } + ], + diagnosticParseResultDiagnostics = [] + } + +diagnosticLineSuccess :: GhcDiagnostic -> DiagnosticParseResult +diagnosticLineSuccess diagnostic = + DiagnosticParseResult + { diagnosticParseResultFailures = [], + diagnosticParseResultDiagnostics = [diagnostic] + } + +looksLikeJsonObjectLine :: String -> Bool +looksLikeJsonObjectLine line = + case dropWhile isSpace line of + '{' : _ -> True + _ -> False + +looksLikeDiagnosticValue :: Value -> Bool +looksLikeDiagnosticValue value = + case value of + Object diagnosticObject -> + any (`KeyMap.member` diagnosticObject) diagnosticPayloadKeys + _ -> False + +diagnosticPayloadKeys :: [Key.Key] +diagnosticPayloadKeys = fmap diagnosticPayloadKeyName [minBound .. maxBound] + +diagnosticPayloadKeyName :: DiagnosticPayloadKey -> Key.Key +diagnosticPayloadKeyName payloadKey = + case payloadKey of + DiagnosticPayloadMessageClass -> "messageClass" + DiagnosticPayloadSeverity -> "severity" + DiagnosticPayloadSpan -> "span" + DiagnosticPayloadCode -> "code" + DiagnosticPayloadReason -> "reason" + DiagnosticPayloadDoc -> "doc" + +normalizeDiagnostic :: FilePath -> GhcDiagnostic -> Maybe NormalizedDiagnostic +normalizeDiagnostic compilerRoot diagnostic = + case (diagnosticCode diagnostic, diagnosticSpan diagnostic) of + (Just code, Just spanValue) -> + Just + NormalizedDiagnostic + { normalizedCode = code, + normalizedFile = normalizeRelativePath (makeRelative compilerRoot (spanFile spanValue)), + normalizedStartLine = spanStartLine spanValue, + normalizedStartCol = spanStartCol spanValue, + normalizedEndLine = spanEndLine spanValue, + normalizedEndCol = spanEndCol spanValue + } + _ -> Nothing + +normalizeErrorDiagnostics :: FilePath -> [GhcDiagnostic] -> [NormalizedDiagnostic] +normalizeErrorDiagnostics compilerRoot = + sort . mapMaybe (normalizeDiagnostic compilerRoot) . errorDiagnostics + +toSnapshotExit :: ExitCode -> SnapshotExit +toSnapshotExit exitCode = + case exitCode of + ExitSuccess -> SnapshotSuccess + ExitFailure _ -> SnapshotFailure + +errorDiagnostics :: [GhcDiagnostic] -> [GhcDiagnostic] +errorDiagnostics = filter isSevError + +isSevError :: GhcDiagnostic -> Bool +isSevError diagnostic = + case diagnosticSeverity diagnostic of + Just severityValue -> severityValue == "Error" + Nothing -> + Text.isInfixOf "MCDiagnostic" (diagnosticClass diagnostic) + && Text.isInfixOf "SevError" (diagnosticClass diagnostic) + +diagnosticCode :: GhcDiagnostic -> Maybe Text +diagnosticCode diagnostic = + diagnosticCodeText diagnostic + <|> find (Text.isPrefixOf "GHC-") (Text.words (diagnosticClass diagnostic)) + +normalizeRelativePath :: FilePath -> FilePath +normalizeRelativePath = normalise diff --git a/src-diagnostic-ghc/Moonlight/Pale/TestSupport/CompileHieFixture.hs b/src-diagnostic-ghc/Moonlight/Pale/TestSupport/CompileHieFixture.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic-ghc/Moonlight/Pale/TestSupport/CompileHieFixture.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} + +{-| Isolated compilation of Haskell source into HIE artifacts and name oracles. -} +module Moonlight.Pale.TestSupport.CompileHieFixture + ( HieFixtureModuleName, + mkHieFixtureModuleName, + CompileHieFixtureFailure (..), + CompiledHieFixture (..), + compileHieFixture, + ) +where + +import Control.Exception (IOException, displayException, try) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.Char (isAlphaNum, isUpper) +import Data.Kind (Type) +import Data.List (sort) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text (Text) +import Data.Text qualified as Text +import Moonlight.Pale.Ghc.Hie.Oracle (ModuleNameOracle (..)) +import Moonlight.Pale.Ghc.Hie.Read (HieReadError, indexHieRoots) +import Moonlight.Pale.Ghc.Hie.SourceKey + ( HieSourceKeyKind, + hieArtifactOracle, + OracleLookup (..), + OracleQuery (..), + TriedKey, + lookupModuleOracle, + ) +import System.Directory + ( canonicalizePath, + createDirectoryIfMissing, + doesDirectoryExist, + findExecutable, + listDirectory, + makeAbsolute, + ) +import System.Exit (ExitCode (..)) +import System.FilePath + ( joinPath, + normalise, + takeDirectory, + takeExtension, + (<.>), + (), + ) +import System.IO (IOMode (WriteMode), withBinaryFile) +import System.IO.Temp (withSystemTempDirectory) +import System.Process + ( CreateProcess (std_err, std_out), + StdStream (UseHandle), + proc, + waitForProcess, + withCreateProcess, + ) + +type HieFixtureModuleName :: Type +newtype HieFixtureModuleName = HieFixtureModuleName (NonEmpty Text) + deriving stock (Eq, Show) + +type CompileHieFixtureFailure :: Type +data CompileHieFixtureFailure + = CompileHieFixtureInvalidModuleName !String + | CompileHieFixtureGhcNotFound + | CompileHieFixtureProcessLaunchFailed !FilePath !(NonEmpty String) !String + | CompileHieFixtureProcessFailed !FilePath !(NonEmpty String) !ExitCode !ByteString !ByteString + | CompileHieFixtureHieDecoderFailed !(NonEmpty HieReadError) + | CompileHieFixtureOracleMissing ![TriedKey] + | CompileHieFixtureOracleAmbiguous !HieSourceKeyKind !FilePath ![FilePath] + | CompileHieFixtureOracleIndexObstruction ![Int] + | CompileHieFixtureHieFileMissing !FilePath + | CompileHieFixtureMultipleHieFiles !FilePath !FilePath ![FilePath] + | CompileHieFixtureSourcePathDisagreement !FilePath !FilePath + | CompileHieFixtureIoFailed !String + deriving stock (Eq, Show) + +type CompiledHieFixture :: Type +data CompiledHieFixture = CompiledHieFixture + { compiledHieFixtureSourcePath :: !FilePath, + compiledHieFixtureSourceBytes :: !ByteString, + compiledHieFixtureHiePath :: !FilePath, + compiledHieFixtureHieBytes :: !ByteString, + compiledHieFixtureOracle :: !ModuleNameOracle, + compiledHieFixtureGhcPath :: !FilePath, + compiledHieFixtureGhcArguments :: !(NonEmpty String), + compiledHieFixtureStdout :: !ByteString, + compiledHieFixtureStderr :: !ByteString + } + deriving stock (Eq, Show) + +mkHieFixtureModuleName :: String -> Either CompileHieFixtureFailure HieFixtureModuleName +mkHieFixtureModuleName rawModuleName = + case NonEmpty.nonEmpty (Text.splitOn (Text.singleton '.') (Text.pack rawModuleName)) of + Just moduleComponents + | all validModuleComponent (NonEmpty.toList moduleComponents) -> + Right (HieFixtureModuleName moduleComponents) + _ -> + Left (CompileHieFixtureInvalidModuleName rawModuleName) + +compileHieFixture :: + HieFixtureModuleName -> + ByteString -> + IO (Either CompileHieFixtureFailure CompiledHieFixture) +compileHieFixture moduleName sourceBytes = + captureIoFailure $ do + maybeGhcPath <- findExecutable "ghc" + case maybeGhcPath of + Nothing -> + pure (Left CompileHieFixtureGhcNotFound) + Just discoveredGhcPath -> do + ghcPath <- makeAbsolute discoveredGhcPath + withSystemTempDirectory "moonlight-pale-hie-fixture" $ \temporaryRoot -> do + canonicalRoot <- canonicalizePath temporaryRoot + compileHieFixtureAtRoot ghcPath moduleName sourceBytes canonicalRoot + +captureIoFailure :: + IO (Either CompileHieFixtureFailure fixture) -> + IO (Either CompileHieFixtureFailure fixture) +captureIoFailure action = do + result <- try @IOException action + pure + ( case result of + Left ioFailure -> Left (CompileHieFixtureIoFailed (displayException ioFailure)) + Right fixtureResult -> fixtureResult + ) + +compileHieFixtureAtRoot :: + FilePath -> + HieFixtureModuleName -> + ByteString -> + FilePath -> + IO (Either CompileHieFixtureFailure CompiledHieFixture) +compileHieFixtureAtRoot ghcPath moduleName sourceBytes temporaryRoot = do + let sourceDirectory = temporaryRoot "src" + hieDirectory = temporaryRoot "hie" + sourcePath = sourceDirectory moduleSourcePath moduleName + stdoutPath = temporaryRoot "ghc.stdout" + stderrPath = temporaryRoot "ghc.stderr" + ghcArguments = + "-fno-code" + :| [ "-fforce-recomp", + "-fwrite-ide-info", + "-hiedir", + hieDirectory, + sourcePath + ] + createDirectoryIfMissing True (takeDirectory sourcePath) + createDirectoryIfMissing True hieDirectory + ByteString.writeFile sourcePath sourceBytes + processResult <- runGhcProcess ghcPath ghcArguments stdoutPath stderrPath + stdoutBytes <- ByteString.readFile stdoutPath + stderrBytes <- ByteString.readFile stderrPath + case processResult of + Left processLaunchFailure -> + pure (Left processLaunchFailure) + Right exitCode@(ExitFailure _) -> + pure + ( Left + ( CompileHieFixtureProcessFailed + ghcPath + ghcArguments + exitCode + stdoutBytes + stderrBytes + ) + ) + Right ExitSuccess -> + decodeCompiledFixture + ghcPath + ghcArguments + sourceDirectory + sourcePath + hieDirectory + stdoutBytes + stderrBytes + +runGhcProcess :: + FilePath -> + NonEmpty String -> + FilePath -> + FilePath -> + IO (Either CompileHieFixtureFailure ExitCode) +runGhcProcess ghcPath ghcArguments stdoutPath stderrPath = + withBinaryFile stdoutPath WriteMode $ \stdoutHandle -> + withBinaryFile stderrPath WriteMode $ \stderrHandle -> do + processResult <- + try @IOException + ( withCreateProcess + ( (proc ghcPath (NonEmpty.toList ghcArguments)) + { std_out = UseHandle stdoutHandle, + std_err = UseHandle stderrHandle + } + ) + (\_ _ _ processHandle -> waitForProcess processHandle) + ) + pure + ( case processResult of + Left processFailure -> + Left + ( CompileHieFixtureProcessLaunchFailed + ghcPath + ghcArguments + (displayException processFailure) + ) + Right exitCode -> + Right exitCode + ) + +decodeCompiledFixture :: + FilePath -> + NonEmpty String -> + FilePath -> + FilePath -> + FilePath -> + ByteString -> + ByteString -> + IO (Either CompileHieFixtureFailure CompiledHieFixture) +decodeCompiledFixture ghcPath ghcArguments sourceDirectory sourcePath hieDirectory stdoutBytes stderrBytes = do + hieFiles <- collectHieFiles hieDirectory + case hieFiles of + [] -> + pure (Left (CompileHieFixtureHieFileMissing hieDirectory)) + firstHiePath : secondHiePath : remainingHiePaths -> + pure + ( Left + ( CompileHieFixtureMultipleHieFiles + firstHiePath + secondHiePath + remainingHiePaths + ) + ) + [hiePath] -> do + (hieReadErrors, oracleIndex) <- indexHieRoots [hieDirectory] + case NonEmpty.nonEmpty hieReadErrors of + Just decoderFailures -> + pure (Left (CompileHieFixtureHieDecoderFailed decoderFailures)) + Nothing -> + retainSelectedFixture + ghcPath + ghcArguments + sourcePath + hiePath + stdoutBytes + stderrBytes + ( lookupModuleOracle + oracleIndex + OracleQuery + { oqGivenPath = normalise sourcePath, + oqAbsolutePath = Just (normalise sourcePath), + oqSourceRoots = [normalise sourceDirectory] + } + ) + +retainSelectedFixture :: + FilePath -> + NonEmpty String -> + FilePath -> + FilePath -> + ByteString -> + ByteString -> + OracleLookup -> + IO (Either CompileHieFixtureFailure CompiledHieFixture) +retainSelectedFixture ghcPath ghcArguments sourcePath hiePath stdoutBytes stderrBytes oracleLookup = + case oracleLookup of + OracleMissing triedKeys -> + pure (Left (CompileHieFixtureOracleMissing triedKeys)) + OracleAmbiguous keyKind keyValue candidates -> + pure (Left (CompileHieFixtureOracleAmbiguous keyKind keyValue candidates)) + OracleIndexObstruction missingOracleIds -> + pure (Left (CompileHieFixtureOracleIndexObstruction missingOracleIds)) + OracleFound _ artifact + | normalise (mnoSourcePath (hieArtifactOracle artifact)) /= normalise sourcePath -> + pure + ( Left + ( CompileHieFixtureSourcePathDisagreement + (normalise sourcePath) + (normalise (mnoSourcePath (hieArtifactOracle artifact))) + ) + ) + | otherwise -> do + retainedSourceBytes <- ByteString.readFile sourcePath + retainedHieBytes <- ByteString.readFile hiePath + pure + ( Right + CompiledHieFixture + { compiledHieFixtureSourcePath = normalise sourcePath, + compiledHieFixtureSourceBytes = retainedSourceBytes, + compiledHieFixtureHiePath = normalise hiePath, + compiledHieFixtureHieBytes = retainedHieBytes, + compiledHieFixtureOracle = hieArtifactOracle artifact, + compiledHieFixtureGhcPath = ghcPath, + compiledHieFixtureGhcArguments = ghcArguments, + compiledHieFixtureStdout = stdoutBytes, + compiledHieFixtureStderr = stderrBytes + } + ) + +collectHieFiles :: FilePath -> IO [FilePath] +collectHieFiles directory = do + entries <- sort <$> listDirectory directory + concat <$> traverse (collectHiePath . (directory )) entries + +collectHiePath :: FilePath -> IO [FilePath] +collectHiePath path = do + pathIsDirectory <- doesDirectoryExist path + if pathIsDirectory + then collectHieFiles path + else pure [normalise path | takeExtension path == ".hie"] + +moduleSourcePath :: HieFixtureModuleName -> FilePath +moduleSourcePath (HieFixtureModuleName moduleComponents) = + joinPath (fmap Text.unpack (NonEmpty.toList moduleComponents)) <.> "hs" + +validModuleComponent :: Text -> Bool +validModuleComponent moduleComponent = + case Text.uncons moduleComponent of + Just (initialCharacter, remainingCharacters) -> + isUpper initialCharacter + && Text.all validModuleContinuationCharacter remainingCharacters + Nothing -> + False + +validModuleContinuationCharacter :: Char -> Bool +validModuleContinuationCharacter character = + isAlphaNum character || character == '_' || character == '\'' diff --git a/src-diagnostic/Moonlight/Pale/Diagnostic/Aggregation/Algebra.hs b/src-diagnostic/Moonlight/Pale/Diagnostic/Aggregation/Algebra.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic/Moonlight/Pale/Diagnostic/Aggregation/Algebra.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE DerivingStrategies #-} + +{-| Monoidal summaries and hotspot indexes over local outcomes. -} +module Moonlight.Pale.Diagnostic.Aggregation.Algebra + ( OutcomeSummary, + outcomeSummaryDiagnostics, + outcomeSummaryProjectionOutcomes, + outcomeSummaryRestrictionOutcomes, + RestrictionIndex, + projectionOutcomeChangedCells, + projectionOutcomeResidual, + projectionOutcomeDiagnostics, + outcomeSummaryFromProjectionOutcome, + outcomeSummaryFromRestrictionOutcome, + outcomeSummaryChangedCells, + outcomeSummaryResidual, + restrictionIndexFromOutcomes, + restrictionIndexStats, + restrictionIndexByMismatch, + restrictionIndexByCell, + restrictionIndexTotal, + topRestrictionHotspots, + ) +where + +import Data.Function ((&)) +import Data.Foldable (Foldable, foldl') +import Data.Kind (Type) +import Data.List (sortOn) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Ord (Down (..)) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Set (Set) +import Data.Set qualified as Set +import Moonlight.Pale.Diagnostic.Local.Propagation + ( ProjectionRunOutcome, + RestrictionOutcomeStat (..), + RestrictionRunOutcome (..), + foldProjectionOutcome, + ) +import Prelude + ( Bool (True), + Double, + Eq, + Int, + Maybe (Just, Nothing), + Monoid (mempty), + Ord, + Semigroup ((<>)), + Show, + all, + fmap, + foldMap, + length, + max, + maybe, + otherwise, + take, + zip, + (+), + (-), + (.), + (<), + (>=), + (==), + (||), + ) + +type OutcomeSummary :: Type -> Type -> Type -> Type -> Type -> Type -> Type +data OutcomeSummary cell mismatch key outcome failure diagnostic = OutcomeSummary + { outcomeSummaryDiagnostics :: !(Seq diagnostic), + outcomeSummaryProjectionOutcomes :: !(Seq (ProjectionRunOutcome cell key outcome failure diagnostic)), + outcomeSummaryRestrictionOutcomes :: !(Seq (RestrictionRunOutcome cell mismatch)) + } + deriving stock (Eq, Show) + +instance Semigroup (OutcomeSummary cell mismatch key outcome failure diagnostic) where + leftSummary <> rightSummary = + OutcomeSummary + { outcomeSummaryDiagnostics = + outcomeSummaryDiagnostics leftSummary + <> outcomeSummaryDiagnostics rightSummary, + outcomeSummaryProjectionOutcomes = + outcomeSummaryProjectionOutcomes leftSummary + <> outcomeSummaryProjectionOutcomes rightSummary, + outcomeSummaryRestrictionOutcomes = + outcomeSummaryRestrictionOutcomes leftSummary + <> outcomeSummaryRestrictionOutcomes rightSummary + } + +instance Monoid (OutcomeSummary cell mismatch key outcome failure diagnostic) where + mempty = + OutcomeSummary + { outcomeSummaryDiagnostics = Seq.empty, + outcomeSummaryProjectionOutcomes = Seq.empty, + outcomeSummaryRestrictionOutcomes = Seq.empty + } + +type RestrictionIndex :: Type -> Type -> Type +newtype RestrictionIndex cell mismatch = RestrictionIndex + { restrictionAtomCounts :: Map (cell, cell, mismatch) Int + } + deriving stock (Eq, Show) + +instance (Ord cell, Ord mismatch) => Semigroup (RestrictionIndex cell mismatch) where + leftIndex <> rightIndex = + RestrictionIndex + ( Map.unionWith + (+) + (restrictionAtomCounts leftIndex) + (restrictionAtomCounts rightIndex) + ) + +instance (Ord cell, Ord mismatch) => Monoid (RestrictionIndex cell mismatch) where + mempty = RestrictionIndex Map.empty + +projectionOutcomeChangedCells :: ProjectionRunOutcome cell key outcome failure diagnostic -> Set cell +projectionOutcomeChangedCells = + foldProjectionOutcome (\_ cells _ _ _ -> cells) (\_ _ -> Set.empty) (\_ _ -> Set.empty) + +projectionOutcomeResidual :: ProjectionRunOutcome cell key outcome failure diagnostic -> Maybe Double +projectionOutcomeResidual = + foldProjectionOutcome (\_ _ _ residual _ -> Just residual) (\_ _ -> Nothing) (\_ _ -> Nothing) + +projectionOutcomeDiagnostics :: ProjectionRunOutcome cell key outcome failure diagnostic -> Seq diagnostic +projectionOutcomeDiagnostics = + foldProjectionOutcome (\_ _ _ _ diagnostics -> diagnostics) (\_ _ -> Seq.empty) (\_ _ -> Seq.empty) + +outcomeSummaryFromProjectionOutcome :: ProjectionRunOutcome cell key outcome failure diagnostic -> OutcomeSummary cell mismatch key outcome failure diagnostic +outcomeSummaryFromProjectionOutcome outcome = + OutcomeSummary + { outcomeSummaryDiagnostics = projectionOutcomeDiagnostics outcome, + outcomeSummaryProjectionOutcomes = Seq.singleton outcome, + outcomeSummaryRestrictionOutcomes = Seq.empty + } + +outcomeSummaryFromRestrictionOutcome :: RestrictionRunOutcome cell mismatch -> OutcomeSummary cell mismatch key outcome failure diagnostic +outcomeSummaryFromRestrictionOutcome outcome = + OutcomeSummary + { outcomeSummaryDiagnostics = Seq.empty, + outcomeSummaryProjectionOutcomes = Seq.empty, + outcomeSummaryRestrictionOutcomes = Seq.singleton outcome + } + +outcomeSummaryChangedCells :: Ord cell => OutcomeSummary cell mismatch key outcome failure diagnostic -> Set cell +outcomeSummaryChangedCells summary = + outcomeSummaryProjectionOutcomes summary + & foldMap projectionOutcomeChangedCells + +outcomeSummaryResidual :: OutcomeSummary cell mismatch key outcome failure diagnostic -> Double +outcomeSummaryResidual summary = + foldl' + (\residualTotal outcome -> maybe residualTotal (residualTotal +) (projectionOutcomeResidual outcome)) + 0 + (outcomeSummaryProjectionOutcomes summary) + +restrictionIndexFromOutcomes :: + (Foldable collection, Ord cell, Ord mismatch) => + collection (RestrictionRunOutcome cell mismatch) -> + RestrictionIndex cell mismatch +restrictionIndexFromOutcomes outcomes = + RestrictionIndex + (foldl' insertRestrictionOutcomeAtoms Map.empty outcomes) +{-# INLINE restrictionIndexFromOutcomes #-} + +insertRestrictionOutcomeAtoms :: + (Ord cell, Ord mismatch) => + Map (cell, cell, mismatch) Int -> + RestrictionRunOutcome cell mismatch -> + Map (cell, cell, mismatch) Int +insertRestrictionOutcomeAtoms atomCounts (RestrictionMismatch sourceCell targetCell mismatches) = + foldl' + (\accumulatedCounts mismatch -> Map.insertWith (+) (sourceCell, targetCell, mismatch) 1 accumulatedCounts) + atomCounts + mismatches + +restrictionIndexStats :: RestrictionIndex cell mismatch -> [RestrictionOutcomeStat cell mismatch] +restrictionIndexStats indexValue = + Map.foldrWithKey + ( \(sourceCell, targetCell, mismatch) occurrences remainingStats -> + RestrictionOutcomeStat + { rosSourceCell = sourceCell, + rosTargetCell = targetCell, + rosMismatch = mismatch, + rosOccurrences = occurrences + } + : remainingStats + ) + [] + (restrictionAtomCounts indexValue) +{-# INLINE restrictionIndexStats #-} + +restrictionIndexByMismatch :: Ord mismatch => RestrictionIndex cell mismatch -> Map mismatch Int +restrictionIndexByMismatch indexValue = + Map.foldlWithKey' + (\counts (_, _, mismatch) occurrences -> Map.insertWith (+) mismatch occurrences counts) + Map.empty + (restrictionAtomCounts indexValue) + +restrictionIndexByCell :: Ord cell => RestrictionIndex cell mismatch -> Map cell Int +restrictionIndexByCell indexValue = + Map.foldlWithKey' + insertCellCounts + Map.empty + (restrictionAtomCounts indexValue) + +insertCellCounts :: + Ord cell => + Map cell Int -> + (cell, cell, mismatch) -> + Int -> + Map cell Int +insertCellCounts counts (sourceCell, targetCell, _) occurrences = + let withSource = Map.insertWith (+) sourceCell occurrences counts + in if sourceCell == targetCell + then withSource + else Map.insertWith (+) targetCell occurrences withSource + +restrictionIndexTotal :: RestrictionIndex cell mismatch -> Int +restrictionIndexTotal = + Map.foldl' (+) 0 . restrictionAtomCounts + +topRestrictionHotspots :: Int -> RestrictionIndex cell mismatch -> [RestrictionOutcomeStat cell mismatch] +topRestrictionHotspots limitValue indexValue + | boundedLimit == 0 = + [] + | restrictionStatsHaveUniformOccurrences stats = + take boundedLimit stats + | boundedLimit >= statCount + || boundedLimit >= statCount - boundedLimit = + stats + & sortOn (Down . rosOccurrences) + & take boundedLimit + | otherwise = + foldl' + (retainHotspot boundedLimit) + Map.empty + (zip [0 ..] stats) + & Map.toDescList + & fmap (\(_, statValue) -> statValue) + where + stats = restrictionIndexStats indexValue + boundedLimit = max 0 limitValue + statCount = length stats + +restrictionStatsHaveUniformOccurrences :: [RestrictionOutcomeStat cell mismatch] -> Bool +restrictionStatsHaveUniformOccurrences stats = + case stats of + [] -> + True + firstStat : remainingStats -> + all + ((== rosOccurrences firstStat) . rosOccurrences) + remainingStats + +retainHotspot :: + Int -> + Map (Int, Down Int) (RestrictionOutcomeStat cell mismatch) -> + (Int, RestrictionOutcomeStat cell mismatch) -> + Map (Int, Down Int) (RestrictionOutcomeStat cell mismatch) +retainHotspot retainedLimit retainedStats (ordinal, statValue) + | retainedLimit == 0 = + Map.empty + | otherwise = + let rank = (rosOccurrences statValue, Down ordinal) + in if Map.size retainedStats < retainedLimit + then Map.insert rank statValue retainedStats + else + case Map.lookupMin retainedStats of + Just (lowestRetainedRank, _) + | lowestRetainedRank < rank -> + Map.insert rank statValue (Map.deleteMin retainedStats) + _ -> + retainedStats diff --git a/src-diagnostic/Moonlight/Pale/Diagnostic/Aggregation/Propagation.hs b/src-diagnostic/Moonlight/Pale/Diagnostic/Aggregation/Propagation.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic/Moonlight/Pale/Diagnostic/Aggregation/Propagation.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DerivingStrategies #-} + +{-| Whole-run propagation traces, summaries, and reports. -} +module Moonlight.Pale.Diagnostic.Aggregation.Propagation + ( PropagationFailure (..), + PropagationTrace (..), + PropagationSummary (..), + PropagationReport (..), + traceProjectionOutcomes, + traceRestrictionOutcomes, + filterReportDiagnostics, + reportTotalMismatches, + ) +where + +import Data.Foldable (foldMap) +import Data.Kind (Type) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Set (Set) +import Moonlight.Pale.Diagnostic.Aggregation.Algebra + ( RestrictionIndex, + restrictionIndexTotal, + ) +import Moonlight.Pale.Diagnostic.Local.Propagation + ( IterationTrace (..), + ProjectionRunOutcome, + RestrictionRunOutcome, + ) +import Prelude (Bool, Double, Eq, Int, Show, String, (.)) + +type PropagationFailure :: Type -> Type -> Type +data PropagationFailure key failure + = PropagationIterationExceeded Int + | PropagationInvariantViolation String + | PropagationProjectionFailure key failure + deriving stock (Eq, Show) + +type PropagationTrace :: Type -> Type -> Type -> Type -> Type -> Type -> Type +newtype PropagationTrace cell mismatch key outcome failure diagnostic = PropagationTrace + { traceIterations :: Seq (IterationTrace cell mismatch key outcome failure diagnostic) + } + deriving stock (Eq, Show) + +type PropagationSummary :: Type -> Type -> Type -> Type +data PropagationSummary cell mismatch diagnostic = PropagationSummary + { summaryChangedCells :: !(Set cell), + summaryIterationCount :: !Int, + summaryConverged :: !Bool, + summaryTotalCellsProcessed :: !Int, + summaryResidualEnergy :: !Double, + summaryDiagnostics :: !(Seq diagnostic), + summaryRestrictionIndex :: !(RestrictionIndex cell mismatch) + } + deriving stock (Eq, Show) + +type PropagationReport :: Type -> Type -> Type -> Type -> Type -> Type -> Type +data PropagationReport cell mismatch key outcome failure diagnostic = PropagationReport + { propagationSummary :: !(PropagationSummary cell mismatch diagnostic), + propagationTrace :: !(PropagationTrace cell mismatch key outcome failure diagnostic) + } + deriving stock (Eq, Show) + +traceProjectionOutcomes :: + PropagationTrace cell mismatch key outcome failure diagnostic -> + Seq (ProjectionRunOutcome cell key outcome failure diagnostic) +traceProjectionOutcomes = + foldMap itProjectionOutcomes . traceIterations + +traceRestrictionOutcomes :: + PropagationTrace cell mismatch key outcome failure diagnostic -> + Seq (RestrictionRunOutcome cell mismatch) +traceRestrictionOutcomes = + foldMap itRestrictionOutcomes . traceIterations + +filterReportDiagnostics :: + (diagnostic -> Bool) -> + PropagationReport cell mismatch key outcome failure diagnostic -> + PropagationReport cell mismatch key outcome failure diagnostic +filterReportDiagnostics predicate report = + report + { propagationSummary = + (propagationSummary report) + { summaryDiagnostics = + Seq.filter predicate (summaryDiagnostics (propagationSummary report)) + } + } + +reportTotalMismatches :: PropagationReport cell mismatch key outcome failure diagnostic -> Int +reportTotalMismatches = + restrictionIndexTotal . summaryRestrictionIndex . propagationSummary diff --git a/src-diagnostic/Moonlight/Pale/Diagnostic/Core.hs b/src-diagnostic/Moonlight/Pale/Diagnostic/Core.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic/Moonlight/Pale/Diagnostic/Core.hs @@ -0,0 +1,111 @@ +{-| Severity-indexed diagnostics and their accumulating value carrier. -} +module Moonlight.Pale.Diagnostic.Core + ( DiagnosticSeverity (..), + filterBySeverity, + exactSeverity, + partitionBySeverity, + Diagnosed (..), + diagnosed, + pureDiagnosed, + emitDiagnostic, + emitDiagnostics, + mapDiagnostics, + filterDiagnostics, + diagnosedValue, + diagnosedDiagnostics, + runDiagnosed, + ) +where + +import Data.Kind (Type) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Foldable (toList) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Prelude + ( Applicative (pure, (<*>)), + Bool, + Bounded, + Enum, + Eq ((==)), + Functor (fmap), + Monad ((>>=)), + Monoid (mempty), + Ord ((>=)), + Read, + Semigroup ((<>)), + Show, + filter, + reverse, + (.), + ) + +type DiagnosticSeverity :: Type +data DiagnosticSeverity + = DiagInfo + | DiagWarning + | DiagError + deriving stock (Eq, Ord, Show, Read, Bounded, Enum) + +filterSeverityBy :: (DiagnosticSeverity -> Bool) -> (d -> DiagnosticSeverity) -> [d] -> [d] +filterSeverityBy keep extract = filter (keep . extract) + +filterBySeverity :: (d -> DiagnosticSeverity) -> DiagnosticSeverity -> [d] -> [d] +filterBySeverity extract threshold = filterSeverityBy (>= threshold) extract + +exactSeverity :: (d -> DiagnosticSeverity) -> DiagnosticSeverity -> [d] -> [d] +exactSeverity extract target = filterSeverityBy (== target) extract + +partitionBySeverity :: (d -> DiagnosticSeverity) -> [d] -> Map DiagnosticSeverity [d] +partitionBySeverity extract = + fmap reverse . Map.fromListWith (<>) . fmap (\d -> (extract d, [d])) + +type Diagnosed :: Type -> Type -> Type +newtype Diagnosed d a = Diagnosed {unDiagnosed :: (Seq d, a)} + deriving stock (Eq, Show) + +instance Functor (Diagnosed d) where + fmap f (Diagnosed (ds, a)) = Diagnosed (ds, f a) + +instance Applicative (Diagnosed d) where + pure a = Diagnosed (Seq.empty, a) + Diagnosed (ds1, f) <*> Diagnosed (ds2, a) = Diagnosed (ds1 <> ds2, f a) + +instance Monad (Diagnosed d) where + Diagnosed (ds1, a) >>= f = + let Diagnosed (ds2, b) = f a + in Diagnosed (ds1 <> ds2, b) + +diagnosed :: a -> [d] -> Diagnosed d a +diagnosed a ds = Diagnosed (Seq.fromList ds, a) + +pureDiagnosed :: a -> Diagnosed d a +pureDiagnosed = pure + +emitDiagnostic :: d -> Diagnosed d () +emitDiagnostic d = Diagnosed (Seq.singleton d, ()) + +emitDiagnostics :: [d] -> Diagnosed d () +emitDiagnostics ds = Diagnosed (Seq.fromList ds, ()) + +mapDiagnostics :: (d -> e) -> Diagnosed d a -> Diagnosed e a +mapDiagnostics f (Diagnosed (ds, a)) = Diagnosed (fmap f ds, a) + +filterDiagnostics :: (d -> Bool) -> Diagnosed d a -> Diagnosed d a +filterDiagnostics p (Diagnosed (ds, a)) = Diagnosed (Seq.filter p ds, a) + +diagnosedValue :: Diagnosed d a -> a +diagnosedValue (Diagnosed (_, a)) = a + +diagnosedDiagnostics :: Diagnosed d a -> [d] +diagnosedDiagnostics (Diagnosed (ds, _)) = toList ds + +runDiagnosed :: Diagnosed d a -> (a, [d]) +runDiagnosed (Diagnosed (ds, a)) = (a, toList ds) + +instance Semigroup a => Semigroup (Diagnosed d a) where + Diagnosed (ds1, a1) <> Diagnosed (ds2, a2) = Diagnosed (ds1 <> ds2, a1 <> a2) + +instance Monoid a => Monoid (Diagnosed d a) where + mempty = Diagnosed (Seq.empty, mempty) diff --git a/src-diagnostic/Moonlight/Pale/Diagnostic/Local/Propagation.hs b/src-diagnostic/Moonlight/Pale/Diagnostic/Local/Propagation.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic/Moonlight/Pale/Diagnostic/Local/Propagation.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DerivingStrategies #-} + +{-| Per-projection and per-restriction propagation outcomes. -} +module Moonlight.Pale.Diagnostic.Local.Propagation + ( ProjectionRunOutcome (..), + foldProjectionOutcome, + RestrictionRunOutcome (..), + RestrictionOutcomeStat (..), + IterationTrace (..), + ) +where + +import Data.Kind (Type) +import Data.Sequence (Seq) +import Data.Set (Set) +import Prelude (Double, Eq, Int, Show, String) + +type ProjectionRunOutcome :: Type -> Type -> Type -> Type -> Type -> Type +data ProjectionRunOutcome cell key outcome failure diagnostic + = ProjectionApplied key (Set cell) outcome Double (Seq diagnostic) + | ProjectionSkipped key String + | ProjectionFailed key failure + deriving stock (Eq, Show) + +foldProjectionOutcome :: + (key -> Set cell -> outcome -> Double -> Seq diagnostic -> r) -> + (key -> String -> r) -> + (key -> failure -> r) -> + ProjectionRunOutcome cell key outcome failure diagnostic -> + r +foldProjectionOutcome applied skipped failed outcome = + case outcome of + ProjectionApplied key changedCells result residual diagnostics -> + applied key changedCells result residual diagnostics + ProjectionSkipped key reason -> + skipped key reason + ProjectionFailed key failure -> + failed key failure + +type RestrictionRunOutcome :: Type -> Type -> Type +data RestrictionRunOutcome cell mismatch + = RestrictionMismatch cell cell [mismatch] + deriving stock (Eq, Show) + +type RestrictionOutcomeStat :: Type -> Type -> Type +data RestrictionOutcomeStat cell mismatch = RestrictionOutcomeStat + { rosSourceCell :: cell, + rosTargetCell :: cell, + rosMismatch :: mismatch, + rosOccurrences :: Int + } + deriving stock (Eq, Show) + +type IterationTrace :: Type -> Type -> Type -> Type -> Type -> Type -> Type +data IterationTrace cell mismatch key outcome failure diagnostic = IterationTrace + { itIterationIndex :: !Int, + itFrontierSize :: !Int, + itChangedCells :: !(Set cell), + itResidualEnergy :: !Double, + itProjectionOutcomes :: !(Seq (ProjectionRunOutcome cell key outcome failure diagnostic)), + itRestrictionOutcomes :: !(Seq (RestrictionRunOutcome cell mismatch)) + } + deriving stock (Eq, Show) diff --git a/src-diagnostic/Moonlight/Pale/Diagnostic/Local/Replay.hs b/src-diagnostic/Moonlight/Pale/Diagnostic/Local/Replay.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic/Moonlight/Pale/Diagnostic/Local/Replay.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE DerivingStrategies #-} + +{-| Validated counters, durations, rates, and replay diagnostics. -} +module Moonlight.Pale.Diagnostic.Local.Replay + ( RateNonFiniteValue (..), + ReplayDiagnosticsValidationError (..), + NonNegativeCount, + nonNegativeCountFromNatural, + mkNonNegativeCount, + nonNegativeCountValue, + zeroNonNegativeCount, + addNonNegativeCount, + diffNonNegativeCount, + Nanoseconds, + nanosecondsFromNatural, + mkNanoseconds, + nanosecondsValue, + zeroNanoseconds, + addNanoseconds, + diffNanoseconds, + Rate, + mkRate, + rateValue, + rateFromCounts, + ReplayDiagnostics (..), + liftReplayDiagnostics2, + diffReplayDiagnostics, + replayTotalRequests, + replayCacheHitRate, + replayIncrementalRate, + replayFallbackRate, + replayExactCoverageRate, + ) +where + +import Data.Kind (Type) +import Numeric.Natural (Natural) +import Prelude + ( Applicative ((<*>)), + Double, + Either (Left, Right), + Eq ((==)), + Int, + Monoid (mempty), + Ord ((<), (>)), + Semigroup ((<>)), + Show, + fromIntegral, + fromRational, + isInfinite, + isNaN, + otherwise, + toRational, + (+), + (-), + (/), + (<$>), + ) + +type RateNonFiniteValue :: Type +data RateNonFiniteValue + = RateNaN + | RateInfinite + deriving stock (Eq, Show) + +type ReplayDiagnosticsValidationError :: Type +data ReplayDiagnosticsValidationError + = NegativeCount Int + | CountDifferenceUnderflow NonNegativeCount NonNegativeCount + | NegativeNanoseconds Int + | NanosecondsDifferenceUnderflow Nanoseconds Nanoseconds + | NonFiniteRate RateNonFiniteValue + | RateOutOfBounds Double + | RateNumeratorExceedsDenominator NonNegativeCount NonNegativeCount + | RateDenominatorZero + deriving stock (Eq, Show) + +type NonNegativeCount :: Type +newtype NonNegativeCount = NonNegativeCount Natural + deriving stock (Eq, Ord, Show) + +nonNegativeCountFromNatural :: Natural -> NonNegativeCount +nonNegativeCountFromNatural = + NonNegativeCount + +mkNonNegativeCount :: Int -> Either ReplayDiagnosticsValidationError NonNegativeCount +mkNonNegativeCount value + | value < 0 = Left (NegativeCount value) + | otherwise = Right (NonNegativeCount (fromIntegral value)) + +nonNegativeCountValue :: NonNegativeCount -> Natural +nonNegativeCountValue (NonNegativeCount value) = + value + +zeroNonNegativeCount :: NonNegativeCount +zeroNonNegativeCount = + NonNegativeCount 0 + +addNonNegativeCount :: NonNegativeCount -> NonNegativeCount -> NonNegativeCount +addNonNegativeCount (NonNegativeCount leftValue) (NonNegativeCount rightValue) = + NonNegativeCount (leftValue + rightValue) + +diffNonNegativeCount :: + NonNegativeCount -> + NonNegativeCount -> + Either ReplayDiagnosticsValidationError NonNegativeCount +diffNonNegativeCount leftCount@(NonNegativeCount leftValue) rightCount@(NonNegativeCount rightValue) + | leftValue < rightValue = Left (CountDifferenceUnderflow leftCount rightCount) + | otherwise = Right (NonNegativeCount (leftValue - rightValue)) + +type Nanoseconds :: Type +newtype Nanoseconds = Nanoseconds Natural + deriving stock (Eq, Ord, Show) + +nanosecondsFromNatural :: Natural -> Nanoseconds +nanosecondsFromNatural = + Nanoseconds + +mkNanoseconds :: Int -> Either ReplayDiagnosticsValidationError Nanoseconds +mkNanoseconds value + | value < 0 = Left (NegativeNanoseconds value) + | otherwise = Right (Nanoseconds (fromIntegral value)) + +nanosecondsValue :: Nanoseconds -> Natural +nanosecondsValue (Nanoseconds value) = + value + +zeroNanoseconds :: Nanoseconds +zeroNanoseconds = + Nanoseconds 0 + +addNanoseconds :: Nanoseconds -> Nanoseconds -> Nanoseconds +addNanoseconds (Nanoseconds leftValue) (Nanoseconds rightValue) = + Nanoseconds (leftValue + rightValue) + +diffNanoseconds :: + Nanoseconds -> + Nanoseconds -> + Either ReplayDiagnosticsValidationError Nanoseconds +diffNanoseconds leftNanoseconds@(Nanoseconds leftValue) rightNanoseconds@(Nanoseconds rightValue) + | leftValue < rightValue = Left (NanosecondsDifferenceUnderflow leftNanoseconds rightNanoseconds) + | otherwise = Right (Nanoseconds (leftValue - rightValue)) + +type Rate :: Type +newtype Rate = Rate Double + deriving stock (Eq, Ord, Show) + +mkRate :: Double -> Either ReplayDiagnosticsValidationError Rate +mkRate value + | isNaN value = Left (NonFiniteRate RateNaN) + | isInfinite value = Left (NonFiniteRate RateInfinite) + | value < 0 = Left (RateOutOfBounds value) + | value > 1 = Left (RateOutOfBounds value) + | value == 0 = Right (Rate 0) + | otherwise = Right (Rate value) + +rateValue :: Rate -> Double +rateValue (Rate value) = + value + +rateFromCounts :: + NonNegativeCount -> + NonNegativeCount -> + Either ReplayDiagnosticsValidationError Rate +rateFromCounts numeratorCount denominatorCount = + case denominatorCount of + NonNegativeCount 0 -> + Left RateDenominatorZero + NonNegativeCount denominatorValue -> + case numeratorCount of + NonNegativeCount numeratorValue + | numeratorValue > denominatorValue -> + Left (RateNumeratorExceedsDenominator numeratorCount denominatorCount) + | otherwise -> + mkRate (fromRational (toRational numeratorValue / toRational denominatorValue)) + +type ReplayDiagnostics :: Type +data ReplayDiagnostics = ReplayDiagnostics + { rdRequestCacheHits :: !NonNegativeCount, + rdRequestCacheMisses :: !NonNegativeCount, + rdFullReplayQueries :: !NonNegativeCount, + rdIncrementalReplayQueries :: !NonNegativeCount, + rdFrontierSeedCount :: !NonNegativeCount, + rdMaterializedRegionCount :: !NonNegativeCount, + rdAffectedRootCount :: !NonNegativeCount, + rdReusedRootCount :: !NonNegativeCount, + rdExactFeasibleRootCount :: !NonNegativeCount, + rdExactInfeasibleRootCount :: !NonNegativeCount, + rdObstructedRootCount :: !NonNegativeCount, + rdFallbackAttemptedRootCount :: !NonNegativeCount, + rdFallbackHitRootCount :: !NonNegativeCount, + rdRegionEnumerationNanoseconds :: !Nanoseconds, + rdRegionAnalysisNanoseconds :: !Nanoseconds, + rdFallbackMatchingNanoseconds :: !Nanoseconds, + rdDatabaseConstructionNanoseconds :: !Nanoseconds, + rdSeedsAfterPruningGates :: !NonNegativeCount, + rdSeedsAfterFrontierFilter :: !NonNegativeCount, + rdSeedsAfterMaterialization :: !NonNegativeCount, + rdSeedsPassingMicrosupport :: !NonNegativeCount, + rdSeedsPassingContext :: !NonNegativeCount, + rdSeedsPassingSpectral :: !NonNegativeCount, + rdSeedsPassingLaplacian :: !NonNegativeCount + } + deriving stock (Eq, Show) + +liftReplayDiagnostics2 :: + (NonNegativeCount -> NonNegativeCount -> NonNegativeCount) -> + (Nanoseconds -> Nanoseconds -> Nanoseconds) -> + ReplayDiagnostics -> + ReplayDiagnostics -> + ReplayDiagnostics +liftReplayDiagnostics2 countFunction nanosecondsFunction a b = + ReplayDiagnostics + { rdRequestCacheHits = countFunction (rdRequestCacheHits a) (rdRequestCacheHits b), + rdRequestCacheMisses = countFunction (rdRequestCacheMisses a) (rdRequestCacheMisses b), + rdFullReplayQueries = countFunction (rdFullReplayQueries a) (rdFullReplayQueries b), + rdIncrementalReplayQueries = countFunction (rdIncrementalReplayQueries a) (rdIncrementalReplayQueries b), + rdFrontierSeedCount = countFunction (rdFrontierSeedCount a) (rdFrontierSeedCount b), + rdMaterializedRegionCount = countFunction (rdMaterializedRegionCount a) (rdMaterializedRegionCount b), + rdAffectedRootCount = countFunction (rdAffectedRootCount a) (rdAffectedRootCount b), + rdReusedRootCount = countFunction (rdReusedRootCount a) (rdReusedRootCount b), + rdExactFeasibleRootCount = countFunction (rdExactFeasibleRootCount a) (rdExactFeasibleRootCount b), + rdExactInfeasibleRootCount = countFunction (rdExactInfeasibleRootCount a) (rdExactInfeasibleRootCount b), + rdObstructedRootCount = countFunction (rdObstructedRootCount a) (rdObstructedRootCount b), + rdFallbackAttemptedRootCount = countFunction (rdFallbackAttemptedRootCount a) (rdFallbackAttemptedRootCount b), + rdFallbackHitRootCount = countFunction (rdFallbackHitRootCount a) (rdFallbackHitRootCount b), + rdRegionEnumerationNanoseconds = nanosecondsFunction (rdRegionEnumerationNanoseconds a) (rdRegionEnumerationNanoseconds b), + rdRegionAnalysisNanoseconds = nanosecondsFunction (rdRegionAnalysisNanoseconds a) (rdRegionAnalysisNanoseconds b), + rdFallbackMatchingNanoseconds = nanosecondsFunction (rdFallbackMatchingNanoseconds a) (rdFallbackMatchingNanoseconds b), + rdDatabaseConstructionNanoseconds = nanosecondsFunction (rdDatabaseConstructionNanoseconds a) (rdDatabaseConstructionNanoseconds b), + rdSeedsAfterPruningGates = countFunction (rdSeedsAfterPruningGates a) (rdSeedsAfterPruningGates b), + rdSeedsAfterFrontierFilter = countFunction (rdSeedsAfterFrontierFilter a) (rdSeedsAfterFrontierFilter b), + rdSeedsAfterMaterialization = countFunction (rdSeedsAfterMaterialization a) (rdSeedsAfterMaterialization b), + rdSeedsPassingMicrosupport = countFunction (rdSeedsPassingMicrosupport a) (rdSeedsPassingMicrosupport b), + rdSeedsPassingContext = countFunction (rdSeedsPassingContext a) (rdSeedsPassingContext b), + rdSeedsPassingSpectral = countFunction (rdSeedsPassingSpectral a) (rdSeedsPassingSpectral b), + rdSeedsPassingLaplacian = countFunction (rdSeedsPassingLaplacian a) (rdSeedsPassingLaplacian b) + } + +instance Semigroup ReplayDiagnostics where + (<>) = liftReplayDiagnostics2 addNonNegativeCount addNanoseconds + +instance Monoid ReplayDiagnostics where + mempty = + ReplayDiagnostics + { rdRequestCacheHits = zeroNonNegativeCount, + rdRequestCacheMisses = zeroNonNegativeCount, + rdFullReplayQueries = zeroNonNegativeCount, + rdIncrementalReplayQueries = zeroNonNegativeCount, + rdFrontierSeedCount = zeroNonNegativeCount, + rdMaterializedRegionCount = zeroNonNegativeCount, + rdAffectedRootCount = zeroNonNegativeCount, + rdReusedRootCount = zeroNonNegativeCount, + rdExactFeasibleRootCount = zeroNonNegativeCount, + rdExactInfeasibleRootCount = zeroNonNegativeCount, + rdObstructedRootCount = zeroNonNegativeCount, + rdFallbackAttemptedRootCount = zeroNonNegativeCount, + rdFallbackHitRootCount = zeroNonNegativeCount, + rdRegionEnumerationNanoseconds = zeroNanoseconds, + rdRegionAnalysisNanoseconds = zeroNanoseconds, + rdFallbackMatchingNanoseconds = zeroNanoseconds, + rdDatabaseConstructionNanoseconds = zeroNanoseconds, + rdSeedsAfterPruningGates = zeroNonNegativeCount, + rdSeedsAfterFrontierFilter = zeroNonNegativeCount, + rdSeedsAfterMaterialization = zeroNonNegativeCount, + rdSeedsPassingMicrosupport = zeroNonNegativeCount, + rdSeedsPassingContext = zeroNonNegativeCount, + rdSeedsPassingSpectral = zeroNonNegativeCount, + rdSeedsPassingLaplacian = zeroNonNegativeCount + } + +diffReplayDiagnostics :: + ReplayDiagnostics -> + ReplayDiagnostics -> + Either ReplayDiagnosticsValidationError ReplayDiagnostics +diffReplayDiagnostics a b = + ReplayDiagnostics + <$> diffNonNegativeCount (rdRequestCacheHits a) (rdRequestCacheHits b) + <*> diffNonNegativeCount (rdRequestCacheMisses a) (rdRequestCacheMisses b) + <*> diffNonNegativeCount (rdFullReplayQueries a) (rdFullReplayQueries b) + <*> diffNonNegativeCount (rdIncrementalReplayQueries a) (rdIncrementalReplayQueries b) + <*> diffNonNegativeCount (rdFrontierSeedCount a) (rdFrontierSeedCount b) + <*> diffNonNegativeCount (rdMaterializedRegionCount a) (rdMaterializedRegionCount b) + <*> diffNonNegativeCount (rdAffectedRootCount a) (rdAffectedRootCount b) + <*> diffNonNegativeCount (rdReusedRootCount a) (rdReusedRootCount b) + <*> diffNonNegativeCount (rdExactFeasibleRootCount a) (rdExactFeasibleRootCount b) + <*> diffNonNegativeCount (rdExactInfeasibleRootCount a) (rdExactInfeasibleRootCount b) + <*> diffNonNegativeCount (rdObstructedRootCount a) (rdObstructedRootCount b) + <*> diffNonNegativeCount (rdFallbackAttemptedRootCount a) (rdFallbackAttemptedRootCount b) + <*> diffNonNegativeCount (rdFallbackHitRootCount a) (rdFallbackHitRootCount b) + <*> diffNanoseconds (rdRegionEnumerationNanoseconds a) (rdRegionEnumerationNanoseconds b) + <*> diffNanoseconds (rdRegionAnalysisNanoseconds a) (rdRegionAnalysisNanoseconds b) + <*> diffNanoseconds (rdFallbackMatchingNanoseconds a) (rdFallbackMatchingNanoseconds b) + <*> diffNanoseconds (rdDatabaseConstructionNanoseconds a) (rdDatabaseConstructionNanoseconds b) + <*> diffNonNegativeCount (rdSeedsAfterPruningGates a) (rdSeedsAfterPruningGates b) + <*> diffNonNegativeCount (rdSeedsAfterFrontierFilter a) (rdSeedsAfterFrontierFilter b) + <*> diffNonNegativeCount (rdSeedsAfterMaterialization a) (rdSeedsAfterMaterialization b) + <*> diffNonNegativeCount (rdSeedsPassingMicrosupport a) (rdSeedsPassingMicrosupport b) + <*> diffNonNegativeCount (rdSeedsPassingContext a) (rdSeedsPassingContext b) + <*> diffNonNegativeCount (rdSeedsPassingSpectral a) (rdSeedsPassingSpectral b) + <*> diffNonNegativeCount (rdSeedsPassingLaplacian a) (rdSeedsPassingLaplacian b) + +replayTotalRequests :: ReplayDiagnostics -> NonNegativeCount +replayTotalRequests d = + addNonNegativeCount (rdRequestCacheHits d) (rdRequestCacheMisses d) + +replayCacheHitRate :: ReplayDiagnostics -> Either ReplayDiagnosticsValidationError Rate +replayCacheHitRate d = + rateFromCounts (rdRequestCacheHits d) (replayTotalRequests d) + +replayIncrementalRate :: ReplayDiagnostics -> Either ReplayDiagnosticsValidationError Rate +replayIncrementalRate d = + let totalQueries = + addNonNegativeCount + (rdFullReplayQueries d) + (rdIncrementalReplayQueries d) + in rateFromCounts (rdIncrementalReplayQueries d) totalQueries + +replayFallbackRate :: ReplayDiagnostics -> Either ReplayDiagnosticsValidationError Rate +replayFallbackRate d = + rateFromCounts (rdFallbackAttemptedRootCount d) (rdAffectedRootCount d) + +replayExactCoverageRate :: ReplayDiagnostics -> Either ReplayDiagnosticsValidationError Rate +replayExactCoverageRate d = + rateFromCounts (rdExactFeasibleRootCount d) (rdAffectedRootCount d) diff --git a/src-diagnostic/Moonlight/Pale/Diagnostic/Local/Rewrite.hs b/src-diagnostic/Moonlight/Pale/Diagnostic/Local/Rewrite.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic/Moonlight/Pale/Diagnostic/Local/Rewrite.hs @@ -0,0 +1,30 @@ +{-| Per-rule rewrite traces and outcome counts. -} +module Moonlight.Pale.Diagnostic.Local.Rewrite + ( RuleTrace (..), + RewriteOutcomeStat (..), + ) +where + +import Data.Kind (Type) +import Prelude (Bool, Eq, Int, Maybe, Show) + +type RuleTrace :: Type -> Type +data RuleTrace ruleId = RuleTrace + { rtRuleId :: ruleId, + rtMatchedCount :: Int, + rtFilteredCount :: Int, + rtScheduledCount :: Int, + rtSkippedByScheduler :: Bool, + rtBannedUntil :: Maybe Int + } + deriving stock (Eq, Show) + +type RewriteOutcomeStat :: Type -> Type +data RewriteOutcomeStat ruleId = RewriteOutcomeStat + { rosRuleId :: ruleId, + rosMatchedCount :: Int, + rosFilteredCount :: Int, + rosScheduledCount :: Int, + rosBannedCount :: Int + } + deriving stock (Eq, Show) diff --git a/src-diagnostic/Moonlight/Pale/Diagnostic/Local/Saturation.hs b/src-diagnostic/Moonlight/Pale/Diagnostic/Local/Saturation.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic/Moonlight/Pale/Diagnostic/Local/Saturation.hs @@ -0,0 +1,45 @@ +{-| Per-iteration saturation traces and their accumulation. -} +module Moonlight.Pale.Diagnostic.Local.Saturation + ( SaturationIterationTrace (..), + SaturationTrace (..), + emptySaturationTrace, + ) +where + +import Data.Kind (Type) +import Moonlight.Pale.Diagnostic.Local.Rewrite (RuleTrace) +import Prelude (Bool, Eq, Int, Monoid (mempty), Semigroup ((<>)), Show) + +type SaturationIterationTrace :: Type -> Type +data SaturationIterationTrace ruleId = SaturationIterationTrace + { sitIteration :: Int, + sitNodeCountBefore :: Int, + sitNodeCountAfter :: Int, + sitBaseEligibleCount :: Int, + sitContextEligibleCount :: Int, + sitAggregatedEligibleCount :: Int, + sitGuidedCount :: Int, + sitScheduledCount :: Int, + sitFactsChanged :: Bool, + sitFactRoundCount :: Int, + sitContextRevision :: Int, + sitRuleTraces :: [RuleTrace ruleId] + } + deriving stock (Eq, Show) + +type SaturationTrace :: Type -> Type +newtype SaturationTrace ruleId = SaturationTrace + { stIterations :: [SaturationIterationTrace ruleId] + } + deriving stock (Eq, Show) + +instance Semigroup (SaturationTrace ruleId) where + leftTrace <> rightTrace = + SaturationTrace (stIterations leftTrace <> stIterations rightTrace) + +instance Monoid (SaturationTrace ruleId) where + mempty = SaturationTrace [] + +emptySaturationTrace :: SaturationTrace ruleId +emptySaturationTrace = + mempty diff --git a/src-diagnostic/Moonlight/Pale/Diagnostic/Summary/Structural.hs b/src-diagnostic/Moonlight/Pale/Diagnostic/Summary/Structural.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic/Moonlight/Pale/Diagnostic/Summary/Structural.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DerivingStrategies #-} + +{-| Whole-object structural and Grothendieck summaries. -} +module Moonlight.Pale.Diagnostic.Summary.Structural + ( StructuralSummary (..), + GrothendieckStructuralSummary (..), + ) +where + +import Data.Kind (Type) +import Moonlight.Pale.Diagnostic.Topology.Cohomology (CoboundaryNilpotenceEvidence) +import Moonlight.Pale.Diagnostic.Topology.Homotopy (NerveHomotopyProfile) +import Prelude (Bool, Double, Eq, Int, Maybe, Read, Show) + +type StructuralSummary :: Type +data StructuralSummary = StructuralSummary + { ssConnectedComponents :: Int, + ssBettiNumbers :: [Int], + ssCellCount :: Int, + ssRestrictionCount :: Int, + ssCoboundaryNilpotent :: Bool, + ssMicrosupportSize :: Maybe Int, + ssCriticalCellCount :: Maybe Int, + ssNoncriticalFraction :: Maybe Double + } + deriving stock (Eq, Show, Read) + +type GrothendieckStructuralSummary :: Type +data GrothendieckStructuralSummary = GrothendieckStructuralSummary + { gssHomotopyProfile :: NerveHomotopyProfile, + gssCellCount :: Int, + gssFaceCount :: Int, + gssObjectCount :: Int, + gssMorphismCount :: Int, + gssCrossContextMorphismCount :: Int, + gssVerticalMorphismCount :: Int, + gssDiagonalMorphismCount :: Int, + gssCoboundaryNilpotenceEvidence :: CoboundaryNilpotenceEvidence + } + deriving stock (Eq, Show, Read) diff --git a/src-diagnostic/Moonlight/Pale/Diagnostic/Topology/Boundary.hs b/src-diagnostic/Moonlight/Pale/Diagnostic/Topology/Boundary.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic/Moonlight/Pale/Diagnostic/Topology/Boundary.hs @@ -0,0 +1,16 @@ +{-| Typed boundary-incidence shape obstructions. -} +module Moonlight.Pale.Diagnostic.Topology.Boundary + ( BoundaryIncidenceShapeError (..), + ) +where + +import Data.Kind (Type) +import Prelude (Eq, Int, Read, Show) + +type BoundaryIncidenceShapeError :: Type +data BoundaryIncidenceShapeError + = BoundaryIncidenceShapeMismatch Int Int Int Int + | BoundaryIncidenceBlockShapeMismatch Int Int Int Int + | BoundaryIncidenceEntryOutOfBounds Int Int Int Int + | BoundaryIncidenceBasisLookupFailure Int Int + deriving stock (Eq, Show, Read) diff --git a/src-diagnostic/Moonlight/Pale/Diagnostic/Topology/Cohomology.hs b/src-diagnostic/Moonlight/Pale/Diagnostic/Topology/Cohomology.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic/Moonlight/Pale/Diagnostic/Topology/Cohomology.hs @@ -0,0 +1,37 @@ +{-| Coboundary-construction obstructions and nilpotence evidence. -} +module Moonlight.Pale.Diagnostic.Topology.Cohomology + ( CoboundaryConstructionError (..), + CoboundaryNilpotenceEvidence (..), + evidenceNilpotent, + ) +where + +import Data.Kind (Type) +import Moonlight.Pale.Diagnostic.Topology.Boundary (BoundaryIncidenceShapeError) +import Prelude (Bool (False, True), Eq, Int, Read, Show, String) + +type CoboundaryConstructionError :: Type +data CoboundaryConstructionError + = CoboundaryBoundaryShapeError BoundaryIncidenceShapeError + | CoboundaryMiddleBasisCardinalityMismatch Int Int + | CoboundaryMiddleBasisCellMismatch Int + | CoboundaryOperatorBuildError String + deriving stock (Eq, Show, Read) + +type CoboundaryNilpotenceEvidence :: Type +data CoboundaryNilpotenceEvidence + = SingleContextNilpotent + | SingleContextNonNilpotent + | MultiContextNilpotent + | MultiContextNonNilpotent + | CoboundaryConstructionFailed CoboundaryConstructionError + deriving stock (Eq, Show, Read) + +evidenceNilpotent :: CoboundaryNilpotenceEvidence -> Bool +evidenceNilpotent evidenceValue = + case evidenceValue of + SingleContextNilpotent -> True + SingleContextNonNilpotent -> False + MultiContextNilpotent -> True + MultiContextNonNilpotent -> False + CoboundaryConstructionFailed _ -> False diff --git a/src-diagnostic/Moonlight/Pale/Diagnostic/Topology/Homotopy.hs b/src-diagnostic/Moonlight/Pale/Diagnostic/Topology/Homotopy.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic/Moonlight/Pale/Diagnostic/Topology/Homotopy.hs @@ -0,0 +1,15 @@ +{-| Connected-component and Betti-number profiles of a diagnostic nerve. -} +module Moonlight.Pale.Diagnostic.Topology.Homotopy + ( NerveHomotopyProfile (..), + ) +where + +import Data.Kind (Type) +import Prelude (Eq, Int, Read, Show) + +type NerveHomotopyProfile :: Type +data NerveHomotopyProfile = NerveHomotopyProfile + { nhpConnectedComponents :: Int, + nhpBettiVector :: [Int] + } + deriving stock (Eq, Show, Read) diff --git a/src-diagnostic/Moonlight/Pale/Diagnostic/Views/Rewrite.hs b/src-diagnostic/Moonlight/Pale/Diagnostic/Views/Rewrite.hs new file mode 100644 --- /dev/null +++ b/src-diagnostic/Moonlight/Pale/Diagnostic/Views/Rewrite.hs @@ -0,0 +1,103 @@ +{-| Derived summaries of saturation and rewrite traces. -} +module Moonlight.Pale.Diagnostic.Views.Rewrite + ( RewriteOutcomeSummary (..), + summarizeSaturationTrace, + ) +where + +import Data.Kind (Type) +import Data.List (foldl', sortOn) +import Data.Map.Strict qualified as Map +import Data.Ord (Down (..)) +import Moonlight.Pale.Diagnostic.Local.Rewrite + ( RewriteOutcomeStat (..), + RuleTrace (..), + ) +import Moonlight.Pale.Diagnostic.Local.Saturation + ( SaturationIterationTrace (..), + SaturationTrace (..), + ) +import Prelude + ( Eq, + Int, + Ord, + Show, + length, + (+), + (.), + (>>=), + ) + +type RewriteOutcomeSummary :: Type -> Type +data RewriteOutcomeSummary ruleId = RewriteOutcomeSummary + { rosIterations :: Int, + rosTotalMatched :: Int, + rosTotalFiltered :: Int, + rosTotalScheduled :: Int, + rosRuleStats :: [RewriteOutcomeStat ruleId] + } + deriving stock (Eq, Show) + +data RewriteSummaryAccumulator ruleId = RewriteSummaryAccumulator + { rsaRuleStats :: !(Map.Map ruleId (RewriteOutcomeStat ruleId)), + rsaTotalMatched :: !Int, + rsaTotalFiltered :: !Int, + rsaTotalScheduled :: !Int + } + +summarizeSaturationTrace :: Ord ruleId => SaturationTrace ruleId -> RewriteOutcomeSummary ruleId +summarizeSaturationTrace saturationTrace = + let accumulated = + foldl' + accumulateSummary + (RewriteSummaryAccumulator Map.empty 0 0 0) + (stIterations saturationTrace >>= sitRuleTraces) + ruleStats = + sortOn + (Down . rosScheduledCount) + (Map.elems (rsaRuleStats accumulated)) + in RewriteOutcomeSummary + { rosIterations = length (stIterations saturationTrace), + rosTotalMatched = rsaTotalMatched accumulated, + rosTotalFiltered = rsaTotalFiltered accumulated, + rosTotalScheduled = rsaTotalScheduled accumulated, + rosRuleStats = ruleStats + } + +accumulateSummary :: + Ord ruleId => + RewriteSummaryAccumulator ruleId -> + RuleTrace ruleId -> + RewriteSummaryAccumulator ruleId +accumulateSummary accumulator ruleTrace = + RewriteSummaryAccumulator + { rsaRuleStats = + Map.insertWith + combineStats + (rtRuleId ruleTrace) + (statFromTrace ruleTrace) + (rsaRuleStats accumulator), + rsaTotalMatched = rsaTotalMatched accumulator + rtMatchedCount ruleTrace, + rsaTotalFiltered = rsaTotalFiltered accumulator + rtFilteredCount ruleTrace, + rsaTotalScheduled = rsaTotalScheduled accumulator + rtScheduledCount ruleTrace + } + +combineStats :: RewriteOutcomeStat ruleId -> RewriteOutcomeStat ruleId -> RewriteOutcomeStat ruleId +combineStats leftStat rightStat = + RewriteOutcomeStat + { rosRuleId = rosRuleId leftStat, + rosMatchedCount = rosMatchedCount leftStat + rosMatchedCount rightStat, + rosFilteredCount = rosFilteredCount leftStat + rosFilteredCount rightStat, + rosScheduledCount = rosScheduledCount leftStat + rosScheduledCount rightStat, + rosBannedCount = rosBannedCount leftStat + rosBannedCount rightStat + } + +statFromTrace :: RuleTrace ruleId -> RewriteOutcomeStat ruleId +statFromTrace ruleTrace = + RewriteOutcomeStat + { rosRuleId = rtRuleId ruleTrace, + rosMatchedCount = rtMatchedCount ruleTrace, + rosFilteredCount = rtFilteredCount ruleTrace, + rosScheduledCount = rtScheduledCount ruleTrace, + rosBannedCount = if rtSkippedByScheduler ruleTrace then 1 else 0 + } diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr.hs @@ -0,0 +1,176 @@ +{-| Scoped Haskell expression syntax, conversion, equivalence, and rendering. -} +module Moonlight.Pale.Ghc.Expr + ( HsVarRef (..), + BinderAnn (..), + HsOpaqueTag (..), + HsPatOpaqueTag (..), + HsRecPatFieldValue (..), + HsRecPatItem (..), + HsPatF (..), + patBinders, + traversePatBinders, + LetRecursion (..), + FixityAssociativity (..), + FixityDeclaration (..), + TypeSignature (..), + ExactIntegral, + exactIntegralSource, + exactIntegralNegative, + exactIntegralValue, + exactIntegralToInteger, + exactIntegralFromInteger, + ExactFractional, + exactFractionalSource, + exactFractionalNegative, + exactFractionalSignificand, + exactFractionalExponent, + exactFractionalBase, + exactFractionalToRational, + exactFractionalFromRational, + ScopeId, + ScopeIdFailure (..), + ScopeCtx (..), + ScopeIndex, + ScopeIndexFailure (..), + ScopeLookupFailure (..), + FreeScopeSummary, + mkScopeId, + scopeIdKey, + rootScopeId, + mkScopeIndex, + scopeIndexRoot, + scopeParentId, + scopeDepthOf, + scopeIsAncestorOf, + scopeComparable, + scopeLca, + scopeCtxLeq, + scopeCtxMeet, + scopeCtxJoin, + scopeObservedCount, + scopeObservedContexts, + scopeTopCtx, + scopeBottomCtx, + binderIntroScope, + binderSiteScope, + emptyFreeScopeSummary, + singletonFreeScopeSummary, + mergeFreeScopeSummary, + mergeFreeScopeSummaryBy, + mergeFreeScopeSummaryByEither, + deleteFreeScopeSummary, + freeScopeSummaryContains, + freeScopeSummarySize, + freeScopeSummaryToList, + freeScopeSupportAnchor, + NormalizedLit (..), + normalizeHsLit, + NormalizedOverLit (..), + normalizeHsOverLit, + NormalizedFieldLabel (..), + normalizeFieldLabel, + NormalizedTypeText (..), + NormalizedArithSeq (..), + TupleBoxity (..), + TupleSlot (..), + HsExprF (..), + HsStmtF (..), + HsGuardStmtF (..), + GuardedAltF (..), + Expr, + exprRegion, + exprScope, + exprFreeScopes, + exprNode, + eraseExpr, + HsExprTag (..), + TagSignature (..), + tagSignatureFromTag, + tagSignatureMember, + SourceRegion (..), + SourceCharRange, + SourceEndConvention (..), + SourceRangeFailure (..), + sourceRegionFromSrcSpan, + sourceRegionFromRealSrcSpan, + sourceCharRangeStart, + sourceCharRangeEnd, + sourceCharRangeFromOffsets, + sourceRegionCharRange, + sourceRegionCharRangeWith, + sourceCharRangeRegion, + sourceCharRangeRegionWith, + sourceCharRangeText, + Binding (..), + Clause (..), + Rhs (..), + BindingGroup, + bindingGroupScope, + bindingGroupComponents, + bindingGroupBindings, + BindingComponent, + bindingComponentRows, + bindingComponentBinders, + bindingComponentDependencies, + bindingComponentRecursion, + BindingComponentRecursion (..), + bindingExpr, + bindingPattern, + bindingNames, + RecordFieldEnvironment, + emptyRecordFieldEnvironment, + recordFieldEnvironmentFromDefinitions, + ConvertedValueBinding, + tlbBinding, + tlbScope, + tlbRegion, + ConvertedInstanceDeclaration (..), + InstanceMethodSection (..), + ConvertedBindingOrigin (..), + ConvertedBindingSite (..), + ModuleDeclaration (..), + ConvertedModule (..), + convertedModuleBindings, + convertedModuleBindingSites, + convertedModuleInstanceMethodObstructions, + convertedModuleTypeSignatures, + convertedModuleFixityDeclarations, + ConvertedModuleMetrics (..), + UnsupportedDeclarationTag (..), + InstanceMethodObstructionCause (..), + InstanceMethodObstruction (..), + RecordWildcardResolutionFailure (..), + ConvertObstruction (..), + recoverableInstanceMethodObstruction, + convertHsExpr, + convertModule, + convertModuleWithRecordFieldEnvironment, + convertHaskellSource, + convertHaskellSourceWithRecordFieldEnvironment, + convertedModuleMetrics, + hsOpaqueTagName, + hsPatOpaqueTagName, + LayoutPolicy (..), + PageWidth, + defaultPageWidth, + mkPageWidth, + ModuleRenderContext (..), + RenderTarget (..), + RenderRefusal (..), + renderSource, + renderRdrName, + renderRoundTripEquivalent, + renderRoundTripGuardStatementsEquivalent, + ) +where + +import Moonlight.Pale.Ghc.Expr.Convert.Coalgebra +import Moonlight.Pale.Ghc.Expr.Convert.Metrics +import Moonlight.Pale.Ghc.Expr.Equivalence + ( renderRoundTripGuardStatementsEquivalent, + ) +import Moonlight.Pale.Ghc.Expr.NameRender (renderRdrName) +import Moonlight.Pale.Ghc.Expr.Opaque +import Moonlight.Pale.Ghc.Expr.Render +import Moonlight.Pale.Ghc.Expr.Scope +import Moonlight.Pale.Ghc.Expr.Syntax diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Coalgebra.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Coalgebra.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Coalgebra.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Pale.Ghc.Expr.Convert.Coalgebra + ( Binding (..), + Clause (..), + Rhs (..), + BindingGroup, + bindingGroupScope, + bindingGroupComponents, + bindingGroupBindings, + BindingComponent, + bindingComponentRows, + bindingComponentBinders, + bindingComponentDependencies, + bindingComponentRecursion, + BindingComponentRecursion (..), + bindingExpr, + bindingPattern, + bindingNames, + ConvertedBindingMetrics, + convertedBindingScopedExprCount, + convertedBindingGlobalVarRefCount, + convertedBindingLocalVarRefCount, + convertedBindingMaxFreeScopeCount, + RecordFieldEnvironment, + emptyRecordFieldEnvironment, + recordFieldEnvironmentFromDefinitions, + ConvertedValueBinding, + tlbBinding, + tlbScope, + tlbRegion, + convertedValueBindingMetrics, + ConvertedInstanceDeclaration (..), + InstanceMethodSection (..), + ConvertedBindingOrigin (..), + ConvertedBindingSite (..), + ModuleDeclaration (..), + ConvertedModule (..), + convertedModuleBindings, + convertedModuleBindingSites, + convertedModuleInstanceMethodObstructions, + convertedModuleTypeSignatures, + convertedModuleFixityDeclarations, + UnsupportedDeclarationTag (..), + InstanceMethodObstructionCause (..), + InstanceMethodObstruction (..), + RecordWildcardResolutionFailure (..), + ConvertObstruction (..), + recoverableInstanceMethodObstruction, + convertHsExpr, + convertModule, + convertModuleWithRecordFieldEnvironment, + convertHaskellSource, + convertHaskellSourceWithRecordFieldEnvironment, + ) +where + +import Control.Monad.State.Strict (evalStateT, runStateT) +import Data.Map.Strict qualified as Map +import Data.Vector qualified as V +import GHC.Hs + ( GhcPs, + HsExpr (..), + HsModule (..), + ) +import Moonlight.Core (Pattern (..)) +import Moonlight.Pale.Ghc.Expr.Convert.Declaration +import Moonlight.Pale.Ghc.Expr.Convert.Expression +import Moonlight.Pale.Ghc.Expr.Convert.Obstruction +import Moonlight.Pale.Ghc.Expr.Convert.Projection +import Moonlight.Pale.Ghc.Expr.Convert.Row +import Moonlight.Pale.Ghc.Expr.Convert.Source +import Moonlight.Pale.Ghc.Expr.Convert.State +import Moonlight.Pale.Ghc.Expr.Scope +import Moonlight.Pale.Ghc.Expr.Syntax +import Moonlight.Pale.Ghc.ModuleSurface (parseHsModule) + +convertHsExpr :: HsExpr GhcPs -> Either ConvertObstruction (Pattern HsExprF) +convertHsExpr exprValue = + eraseExpr <$> evalStateT (convertExpr Map.empty Nothing exprValue) initialConvState + +convertModule :: String -> HsModule GhcPs -> Either ConvertObstruction ConvertedModule +convertModule = + convertModuleWithRecordFieldEnvironment emptyRecordFieldEnvironment + +convertModuleWithRecordFieldEnvironment :: + RecordFieldEnvironment -> + String -> + HsModule GhcPs -> + Either ConvertObstruction ConvertedModule +convertModuleWithRecordFieldEnvironment recordFieldEnvironment moduleContents moduleValue = do + let moduleSourceIndex = sourceSliceIndex moduleContents + (declarations, finalState) <- + runStateT + (traverse (convertLocatedDecl moduleSourceIndex) (hsmodDecls moduleValue)) + (initialConvStateWithRecordFieldEnvironment recordFieldEnvironment) + let scopeParents = V.fromList (reverse (csScopeParentsRev finalState)) + binderIntro = V.fromList (reverse (csBinderIntroRev finalState)) + scopeIndex <- + either + (Left . ConvertScopeIndexFailure) + Right + (mkScopeIndex scopeParents binderIntro) + pure + ConvertedModule + { cmDeclarations = V.fromList declarations, + cmScopeIndex = scopeIndex, + cmLambdaSites = reverse (csLambdaSites finalState), + cmLetSites = reverse (csLetSites finalState) + } + +convertHaskellSource :: FilePath -> String -> Either ConvertObstruction ConvertedModule +convertHaskellSource = + convertHaskellSourceWithRecordFieldEnvironment emptyRecordFieldEnvironment + +convertHaskellSourceWithRecordFieldEnvironment :: + RecordFieldEnvironment -> + FilePath -> + String -> + Either ConvertObstruction ConvertedModule +convertHaskellSourceWithRecordFieldEnvironment recordFieldEnvironment sourcePath moduleContents = + either + (Left . ConvertParseFailure) + (convertModuleWithRecordFieldEnvironment recordFieldEnvironment moduleContents) + (parseHsModule sourcePath moduleContents) diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Declaration.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Declaration.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Declaration.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Pale.Ghc.Expr.Convert.Declaration + ( fixityAssociativityFromGhc, + convertLocatedDecl, + convertDecl, + convertSignatureDeclaration, + opaqueDeclaration, + convertValueBinding + ) +where + +import Data.Foldable (toList) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import GHC.Hs + ( ClsInstDecl (..), + GhcPs, + HsBind, + HsDecl (..), + InstDecl (..), + LHsBind, + LHsDecl, + FixitySig (..), + Sig (..), + ) +import GHC.Parser.Annotation (getLocA) +import Language.Haskell.Syntax.Basic (Fixity (..), FixityDirection (..)) +import GHC.Types.SrcLoc (unLoc) +import Moonlight.Pale.Ghc.Expr.Convert.Expression +import Moonlight.Pale.Ghc.Expr.Convert.Obstruction +import Moonlight.Pale.Ghc.Expr.Convert.Pattern +import Moonlight.Pale.Ghc.Expr.Convert.Row +import Moonlight.Pale.Ghc.Expr.Convert.Source +import Moonlight.Pale.Ghc.Expr.Convert.State +import Moonlight.Pale.Ghc.Expr.Syntax + +fixityAssociativityFromGhc :: FixityDirection -> FixityAssociativity +fixityAssociativityFromGhc = \case + InfixL -> FixityLeft + InfixR -> FixityRight + InfixN -> FixityNone + +convertLocatedDecl :: SourceSliceIndex -> LHsDecl GhcPs -> ConvM ModuleDeclaration +convertLocatedDecl moduleSourceIndex locatedDecl = + convertDecl + moduleSourceIndex + (sourceRegionFromSrcSpan (getLocA locatedDecl)) + (unLoc locatedDecl) + +convertDecl :: SourceSliceIndex -> Maybe SourceRegion -> HsDecl GhcPs -> ConvM ModuleDeclaration +convertDecl moduleSourceIndex declRegion = \case + ValD _ bindValue -> + ValueDeclaration <$> convertValueBinding declRegion bindValue + SigD _ signature -> + convertSignatureDeclaration moduleSourceIndex declRegion signature + TyClD {} -> + opaqueDeclaration moduleSourceIndex declRegion UnsupportedTypeOrClassDeclaration + InstD _ instanceDeclaration -> + convertInstanceDeclaration moduleSourceIndex declRegion instanceDeclaration + DerivD {} -> + opaqueDeclaration moduleSourceIndex declRegion UnsupportedDerivingDeclaration + KindSigD {} -> + opaqueDeclaration moduleSourceIndex declRegion UnsupportedKindSignatureDeclaration + DefD {} -> + opaqueDeclaration moduleSourceIndex declRegion UnsupportedDefaultDeclaration + ForD {} -> + opaqueDeclaration moduleSourceIndex declRegion UnsupportedForeignDeclaration + WarningD {} -> + opaqueDeclaration moduleSourceIndex declRegion UnsupportedWarningDeclaration + AnnD {} -> + opaqueDeclaration moduleSourceIndex declRegion UnsupportedAnnotationDeclaration + RuleD {} -> + opaqueDeclaration moduleSourceIndex declRegion UnsupportedRuleDeclaration + SpliceD {} -> + opaqueDeclaration moduleSourceIndex declRegion UnsupportedSpliceDeclaration + DocD {} -> + opaqueDeclaration moduleSourceIndex declRegion UnsupportedDocumentationDeclaration + RoleAnnotD {} -> + opaqueDeclaration moduleSourceIndex declRegion UnsupportedRoleAnnotationDeclaration + +convertSignatureDeclaration :: + SourceSliceIndex -> + Maybe SourceRegion -> + Sig GhcPs -> + ConvM ModuleDeclaration +convertSignatureDeclaration moduleSourceIndex declarationRegion = \case + TypeSig _ names signatureType -> + case NonEmpty.nonEmpty (fmap unLoc names) of + Nothing -> + throwConvert (ConvertEmptyTypeSignature declarationRegion) + Just signatureNames -> + pure + ( TypeSignatureDeclaration + TypeSignature + { typeSignatureNames = signatureNames, + typeSignatureType = normalizedTypeText signatureType + } + ) + FixSig _ (FixitySig _ operatorNames (Fixity precedence direction)) -> + case NonEmpty.nonEmpty (fmap unLoc operatorNames) of + Nothing -> + throwConvert (ConvertEmptyFixityDeclaration declarationRegion) + Just fixityOperatorNames -> + pure + ( FixityDeclarationNode + FixityDeclaration + { fixityAssociativity = fixityAssociativityFromGhc direction, + fixityPrecedence = precedence, + fixityOperators = fixityOperatorNames + } + ) + PatSynSig {} -> + opaqueDeclaration moduleSourceIndex declarationRegion UnsupportedPatternSynonymSignature + ClassOpSig {} -> + opaqueDeclaration moduleSourceIndex declarationRegion UnsupportedClassOperationSignature + InlineSig {} -> + opaqueDeclaration moduleSourceIndex declarationRegion UnsupportedInlineSignature + SpecSig {} -> + opaqueDeclaration moduleSourceIndex declarationRegion UnsupportedSpecializationSignature + SpecSigE {} -> + opaqueDeclaration moduleSourceIndex declarationRegion UnsupportedExpressionSpecializationSignature + SpecInstSig {} -> + opaqueDeclaration moduleSourceIndex declarationRegion UnsupportedInstanceSpecializationSignature + MinimalSig {} -> + opaqueDeclaration moduleSourceIndex declarationRegion UnsupportedMinimalSignature + SCCFunSig {} -> + opaqueDeclaration moduleSourceIndex declarationRegion UnsupportedCostCentreSignature + CompleteMatchSig {} -> + opaqueDeclaration moduleSourceIndex declarationRegion UnsupportedCompleteMatchSignature + +opaqueDeclaration :: + SourceSliceIndex -> + Maybe SourceRegion -> + UnsupportedDeclarationTag -> + ConvM ModuleDeclaration +opaqueDeclaration moduleSourceIndex declarationRegion declarationTag = + uncurry (OpaqueDeclaration declarationTag) + <$> requireDeclarationSource + moduleSourceIndex + declarationRegion + (ConvertDeclarationSourceUnavailable declarationRegion declarationTag) + +convertInstanceDeclaration :: + SourceSliceIndex -> + Maybe SourceRegion -> + InstDecl GhcPs -> + ConvM ModuleDeclaration +convertInstanceDeclaration moduleSourceIndex declarationRegion = \case + ClsInstD {cid_inst = ClsInstDecl {cid_binds = methodBindings}} -> do + (instanceRegion, instanceSource) <- + requireDeclarationSource + moduleSourceIndex + declarationRegion + (ConvertInstanceDeclarationSourceUnavailable declarationRegion) + methodSections <- + traverse convertLocatedInstanceMethod (toList methodBindings) + pure + ( InstanceDeclarationNode + ConvertedInstanceDeclaration + { convertedInstanceRegion = instanceRegion, + convertedInstanceSource = instanceSource, + convertedInstanceMethods = methodSections + } + ) + DataFamInstD {} -> + opaqueDeclaration + moduleSourceIndex + declarationRegion + UnsupportedDataFamilyInstanceDeclaration + TyFamInstD {} -> + opaqueDeclaration + moduleSourceIndex + declarationRegion + UnsupportedTypeFamilyInstanceDeclaration + +convertLocatedInstanceMethod :: + LHsBind GhcPs -> + ConvM InstanceMethodSection +convertLocatedInstanceMethod locatedBinding = do + let methodRegion = + sourceRegionFromSrcSpan (getLocA locatedBinding) + methodResult <- + runInstanceMethodSection + methodRegion + (convertValueBinding methodRegion (unLoc locatedBinding)) + pure + ( case methodResult of + Left methodObstruction -> + ObstructedInstanceMethod methodObstruction + Right convertedBinding -> + TraversableInstanceMethod convertedBinding + ) + +requireDeclarationSource :: + SourceSliceIndex -> + Maybe SourceRegion -> + ConvertObstruction -> + ConvM (SourceRegion, String) +requireDeclarationSource moduleSourceIndex declarationRegion unavailableObstruction = + case declarationRegion >>= sourceSliceForRegion moduleSourceIndex of + Just declarationSection -> + pure declarationSection + Nothing -> + throwConvert unavailableObstruction + +convertValueBinding :: Maybe SourceRegion -> HsBind GhcPs -> ConvM ConvertedValueBinding +convertValueBinding declRegion bindValue = do + bindingScope <- freshChildScope + convertedBinding <- + withScope bindingScope $ do + headPattern <- bindingHeadPatternFromBind declRegion bindValue + convertBindingWithPattern Map.empty headPattern bindValue + let !bindingMetrics = + convertedExpressionMetrics (cbExpression convertedBinding) + pure + ConvertedValueBinding + { convertedValueBindingValue = cbBinding convertedBinding, + convertedValueBindingScope = bindingScope, + convertedValueBindingRegion = declRegion, + convertedValueBindingMetricSection = bindingMetrics + } diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Dependencies.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Dependencies.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Dependencies.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Pale.Ghc.Expr.Convert.Dependencies + ( BindingDependencyFailure (..), + inferBindingComponents, + singletonBindingComponent, + bindingComponentsRecursion, + ) +where + +import Data.Graph (SCC (..), stronglyConnComp) +import Data.Foldable qualified as Foldable +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.Kind (Type) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Moonlight.Core (BinderId) +import Moonlight.Pale.Ghc.Expr.Syntax + +type BindingDependencyFailure :: Type +data BindingDependencyFailure + = EmptyRecursiveBindingComponent + | EmptyBindingComponentPartition + deriving stock (Eq, Ord, Show) + +inferBindingComponents :: + NonEmpty.NonEmpty HsPatF -> + IntMap (Set BinderId) -> + Either BindingDependencyFailure (NonEmpty.NonEmpty BindingComponent) +inferBindingComponents (bindingPattern NonEmpty.:| []) dependenciesByRow = + let rowDependencies = + IntMap.findWithDefault Set.empty 0 dependenciesByRow + referencesOwnBinder = + case bindingPattern of + PVarP binderAnn -> + Set.member (baId binderAnn) rowDependencies + _ -> + not + ( Set.disjoint + (Set.fromList (fmap baId (patBinders bindingPattern))) + rowDependencies + ) + in Right (singletonBindingComponent bindingPattern referencesOwnBinder) +inferBindingComponents bindingPatterns dependenciesByRow = + let indexedPatterns = + zip [0 :: Int ..] (NonEmpty.toList bindingPatterns) + binderOwnerRows = + Map.fromList + [ (baId binderAnn, rowIndex) + | (rowIndex, bindingPattern) <- indexedPatterns, + binderAnn <- patBinders bindingPattern + ] + groupBinderIds = + Map.keysSet binderOwnerRows + in if + Foldable.all + (Set.disjoint groupBinderIds) + dependenciesByRow + then + maybe + (Left EmptyBindingComponentPartition) + Right + ( NonEmpty.nonEmpty + ( fmap + independentComponent + (reverse indexedPatterns) + ) + ) + else + let dependencyNodes = + fmap + (bindingDependencyNode groupBinderIds binderOwnerRows) + indexedPatterns + dependencyComponents = + stronglyConnComp dependencyNodes + in do + components <- traverse componentFromScc dependencyComponents + maybe + (Left EmptyBindingComponentPartition) + Right + (NonEmpty.nonEmpty components) + where + independentComponent :: (Int, HsPatF) -> BindingComponent + independentComponent (rowIndex, bindingPattern) = + BindingComponent + { bindingComponentRows = rowIndex NonEmpty.:| [], + bindingComponentBinders = + Set.toList (Set.fromList (fmap baId (patBinders bindingPattern))), + bindingComponentDependencies = [], + bindingComponentRecursion = AcyclicBindingComponent + } + + bindingDependencyNode :: + Set BinderId -> + Map.Map BinderId Int -> + (Int, HsPatF) -> + ((Int, [BinderId], [BinderId]), Int, [Int]) + bindingDependencyNode groupBinderIds binderOwnerRows (rowIndex, bindingPattern) = + let rhsDependencies = + Set.toList + ( Set.intersection + groupBinderIds + (IntMap.findWithDefault Set.empty rowIndex dependenciesByRow) + ) + dependencyRows = + Set.toList + ( Set.fromList + ( foldMap + (\binderId -> maybe [] (: []) (Map.lookup binderId binderOwnerRows)) + rhsDependencies + ) + ) + in ( ( rowIndex, + fmap baId (patBinders bindingPattern), + rhsDependencies + ), + rowIndex, + dependencyRows + ) + + componentFromScc = \case + AcyclicSCC rowPayload -> + Right + (mkComponent (rowPayload NonEmpty.:| []) AcyclicBindingComponent) + CyclicSCC rowPayloads -> + case NonEmpty.nonEmpty rowPayloads of + Nothing -> + Left EmptyRecursiveBindingComponent + Just nonEmptyRowPayloads -> + Right + (mkComponent nonEmptyRowPayloads RecursiveBindingComponent) + + mkComponent rowPayloads recursionValue = + let componentRows = + fmap (\(rowIndex, _, _) -> rowIndex) rowPayloads + componentBinders = + Set.toList + ( foldMap + (Set.fromList . (\(_, binderIds, _) -> binderIds)) + rowPayloads + ) + binderSet = + Set.fromList componentBinders + externalDependencies = + foldMap + (Set.fromList . (\(_, _, dependencyIds) -> dependencyIds)) + rowPayloads + `Set.difference` binderSet + in BindingComponent + { bindingComponentRows = componentRows, + bindingComponentBinders = componentBinders, + bindingComponentDependencies = Set.toList externalDependencies, + bindingComponentRecursion = recursionValue + } + +singletonBindingComponent :: HsPatF -> Bool -> NonEmpty.NonEmpty BindingComponent +singletonBindingComponent bindingPattern referencesOwnBinder = + BindingComponent + { bindingComponentRows = 0 NonEmpty.:| [], + bindingComponentBinders = + case bindingPattern of + PVarP binderAnn -> + [baId binderAnn] + _ -> + Set.toList (Set.fromList (fmap baId (patBinders bindingPattern))), + bindingComponentDependencies = [], + bindingComponentRecursion = + if referencesOwnBinder + then RecursiveBindingComponent + else AcyclicBindingComponent + } + NonEmpty.:| [] + +bindingComponentsRecursion :: NonEmpty.NonEmpty BindingComponent -> LetRecursion +bindingComponentsRecursion bindingComponents + | any ((== RecursiveBindingComponent) . bindingComponentRecursion) bindingComponents = + RecursiveBinds + | any (not . null . bindingComponentDependencies) bindingComponents = + AcyclicDependentBinds + | otherwise = + NonRecursiveBinds diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Expression.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Expression.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Expression.hs @@ -0,0 +1,798 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Pale.Ghc.Expr.Convert.Expression + ( convertExpr, + convertLocatedExpr, + convertBindingWithPattern, + convertSourceMatchGroup, + convertSimpleSourceClause, + convertSourceClause, + convertSourceRhs, + convertLambdaLikeMatchGroup, + convertClauses, + convertClause, + convertLambdaBinders, + convertCaseAlternatives, + convertCaseAlternative, + convertGRHSs, + convertGuardedAlt, + convertGuardedAltBody, + prependGuardStatement, + convertStatements, + convertLocalBinds, + convertValBinds, + convertTupleArg, + flattenOpChain, + flattenLocatedOpChain, + convertRecordFields, + convertRecordUpdFields, + convertRecordField, + convertArithSeq + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NonEmpty +import GHC.Hs + ( ArithSeqInfo (..), + ExprLStmt, + FieldOcc (..), + GRHS (..), + GRHSs (..), + GuardLStmt, + GhcPs, + HsBind, + HsBindLR (..), + HsExpr (..), + HsFieldBind (..), + HsLocalBinds, + HsLocalBindsLR (..), + HsPragE (HsPragSCC), + HsRecField, + HsRecFields (..), + HsTupArg (..), + HsValBindsLR (..), + LGRHS, + LHsExpr, + LHsRecUpdFields (..), + LMatch, + Match (..), + MatchGroup (..), + StmtLR (..), + ) +import GHC.Parser.Annotation (getLocA) +import GHC.Types.Name.Reader (RdrName) +import GHC.Types.SrcLoc (unLoc) +import Moonlight.Pale.Ghc.Expr.Convert.Dependencies qualified as Dependencies +import Moonlight.Pale.Ghc.Expr.Convert.Obstruction +import Moonlight.Pale.Ghc.Expr.Convert.Pattern +import Moonlight.Pale.Ghc.Expr.Convert.Projection +import Moonlight.Pale.Ghc.Expr.Convert.Row +import Moonlight.Pale.Ghc.Expr.Convert.Source +import Moonlight.Pale.Ghc.Expr.Convert.State +import Moonlight.Pale.Ghc.Expr.Opaque +import Moonlight.Pale.Ghc.Expr.Scope +import Moonlight.Pale.Ghc.Expr.Syntax + +convertExpr :: Env -> Maybe SourceRegion -> HsExpr GhcPs -> ConvM ConvExpr +convertExpr env region = \case + HsVar _ nameValue -> do + variableReference <- resolveVarRef env (unLoc nameValue) + mkConvExpr region (VarF variableReference) + HsOverLabel {} -> + throwUnsupportedExpression region OpaqueOverLabel + HsIPVar {} -> + throwUnsupportedExpression region OpaqueIPVar + HsOverLit _ overLitValue -> + mkConvExpr region (OverLitF (normalizeHsOverLit overLitValue)) + HsLit _ literalValue -> + mkConvExpr region (LitF (normalizeHsLit literalValue)) + HsLam _ _ matchGroupValue -> + convertLambdaLikeMatchGroup env region matchGroupValue + HsApp _ functionValue argumentValue -> do + functionExpr <- convertLocatedExpr env functionValue + argumentExpr <- convertLocatedExpr env argumentValue + mkConvExpr region (AppF functionExpr argumentExpr) + HsAppType _ exprValue typeValue -> do + innerExpr <- convertLocatedExpr env exprValue + mkConvExpr region (AppTypeF innerExpr (normalizedTypeText typeValue)) + OpApp _ leftValue operatorValue rightValue -> do + let (firstOperand, chainTail) = + flattenOpChain leftValue operatorValue rightValue + convertedFirst <- convertLocatedExpr env firstOperand + convertedTail <- + traverse + ( \(operatorTerm, operandTerm) -> + (,) + <$> convertLocatedExpr env operatorTerm + <*> convertLocatedExpr env operandTerm + ) + chainTail + mkConvExpr region (OpChainF convertedFirst convertedTail) + NegApp _ exprValue _ -> do + innerExpr <- convertLocatedExpr env exprValue + mkConvExpr region (NegF innerExpr) + HsPar _ exprValue -> do + innerExpr <- convertLocatedExpr env exprValue + mkConvExpr region (ParF innerExpr) + SectionL _ exprValue operatorValue -> do + leftExpr <- convertLocatedExpr env exprValue + operatorExpr <- convertLocatedExpr env operatorValue + mkConvExpr region (SectionLF leftExpr operatorExpr) + SectionR _ operatorValue exprValue -> do + operatorExpr <- convertLocatedExpr env operatorValue + rightExpr <- convertLocatedExpr env exprValue + mkConvExpr region (SectionRF operatorExpr rightExpr) + ExplicitTuple _ tupleArgs boxity -> do + tupleExprs <- traverse (convertTupleArg env) tupleArgs + mkConvExpr region (ExplicitTupleF (convertTupleBoxity boxity) tupleExprs) + ExplicitSum {} -> + throwUnsupportedExpression region OpaqueExplicitSum + HsCase _ scrutineeValue matchGroupValue -> do + scrutineeExpr <- convertLocatedExpr env scrutineeValue + alternatives <- convertCaseAlternatives env matchGroupValue + mkConvExpr region (CaseF scrutineeExpr alternatives) + HsIf _ conditionValue thenValue elseValue -> do + conditionExpr <- convertLocatedExpr env conditionValue + thenExpr <- convertLocatedExpr env thenValue + elseExpr <- convertLocatedExpr env elseValue + mkConvExpr region (IfF conditionExpr thenExpr elseExpr) + HsMultiIf _ grhsValues -> do + guardedAlts <- traverse (convertGuardedAlt env) (NonEmpty.toList grhsValues) + mkConvExpr region (MultiIfF guardedAlts) + HsLet _ localBindsValue bodyValue -> + convertLocalBinds region env localBindsValue >>= \case + Nothing -> + throwUnsupportedExpression region OpaqueEmptyLocalBinds + Just convertedBinds -> do + bodyExpr <- + withScope + (clbScope convertedBinds) + (convertLocatedExpr (clbEnv convertedBinds) bodyValue) + mkConvExpr region (LetF (clbRecursion convertedBinds) (clbBindings convertedBinds) bodyExpr) + HsDo _ _ statementValues -> do + statements <- convertStatements env (unLoc statementValues) + mkConvExpr region (DoF statements) + ExplicitList _ exprValues -> do + listExprs <- traverse (convertLocatedExpr env) exprValues + mkConvExpr region (ExplicitListF listExprs) + RecordCon {rcon_con = constructorValue, rcon_flds = recordFieldsValue} -> do + constructorExpr <- mkConvExpr Nothing (VarF (GlobalName (unLoc constructorValue))) + fieldValues <- convertRecordFields env recordFieldsValue + mkConvExpr region (RecordConF constructorExpr fieldValues) + RecordUpd {rupd_expr = recordValue, rupd_flds = recordFieldsValue} -> do + fieldValues <- convertRecordUpdFields region env recordFieldsValue + recordExpr <- convertLocatedExpr env recordValue + mkConvExpr region (RecordUpdF recordExpr fieldValues) + HsGetField {} -> + throwUnsupportedExpression region OpaqueGetField + HsProjection {} -> + throwUnsupportedExpression region OpaqueProjection + ExprWithTySig _ exprValue sigValue -> do + innerExpr <- convertLocatedExpr env exprValue + mkConvExpr region (ExprWithTySigF innerExpr (normalizedTypeText sigValue)) + ArithSeq _ _ arithSeqValue -> do + convertedSeq <- convertArithSeq env arithSeqValue + mkConvExpr region (ArithSeqF convertedSeq) + HsTypedBracket {} -> + throwUnsupportedExpression region OpaqueTypedBracket + HsUntypedBracket {} -> + throwUnsupportedExpression region OpaqueUntypedBracket + HsTypedSplice {} -> + throwUnsupportedExpression region OpaqueTypedSplice + HsUntypedSplice {} -> + throwUnsupportedExpression region OpaqueUntypedSplice + HsProc {} -> + throwUnsupportedExpression region OpaqueProc + HsStatic {} -> + throwUnsupportedExpression region OpaqueStatic + HsPragE _ (HsPragSCC {}) exprValue -> + convertLocatedExpr env exprValue + HsEmbTy {} -> + throwUnsupportedExpression region OpaqueEmbTy + HsHole {} -> + throwUnsupportedExpression region OpaqueHole + HsForAll {} -> + throwUnsupportedExpression region OpaqueForAll + HsQual {} -> + throwUnsupportedExpression region OpaqueQual + HsFunArr {} -> + throwUnsupportedExpression region OpaqueFunArr + +convertLocatedExpr :: Env -> LHsExpr GhcPs -> ConvM ConvExpr +convertLocatedExpr env locatedExpr = + convertExpr env (sourceRegionFromSrcSpan (getLocA locatedExpr)) (unLoc locatedExpr) + +convertBindingWithPattern :: Env -> HsPatF -> HsBind GhcPs -> ConvM ConvertedBinding +convertBindingWithPattern env headPattern = \case + FunBind {fun_matches = matchGroupValue} -> + case headPattern of + PVarP binderAnn -> do + (clauses, expressionValue) <- + convertSourceMatchGroup env Nothing matchGroupValue + pure + ConvertedBinding + { cbBinding = FunctionBinding binderAnn clauses, + cbExpression = expressionValue + } + _ -> + throwConvert + (ConvertUnsupportedTopLevelBinding Nothing "non-variable function binding") + PatBind {pat_rhs = grhssValue} -> do + (rhsValue, expressionValue) <- convertSourceRhs env grhssValue + pure + ConvertedBinding + { cbBinding = PatternBinding headPattern rhsValue, + cbExpression = expressionValue + } + VarBind {var_rhs = rhsValue} -> do + expressionValue <- convertLocatedExpr env rhsValue + pure + ConvertedBinding + { cbBinding = PatternBinding headPattern (UnguardedRhs expressionValue Nothing), + cbExpression = expressionValue + } + PatSynBind {} -> + throwConvert (ConvertUnsupportedTopLevelBinding Nothing "PatSynBind") + +convertSourceMatchGroup :: + Env -> + Maybe SourceRegion -> + MatchGroup GhcPs (LHsExpr GhcPs) -> + ConvM (NonEmpty Clause, Expr) +convertSourceMatchGroup env region = \case + MG {mg_alts = alternativesValue} -> + case unLoc alternativesValue of + [matchValue] + | Just _ <- simpleLambdaBinderNames (unLoc matchValue) -> do + (clauseValue, expressionValue) <- + convertSimpleSourceClause env region (unLoc matchValue) + pure (clauseValue :| [], expressionValue) + matchValues -> do + convertedClauses <- + traverse (convertSourceClause env . unLoc) matchValues + case NonEmpty.nonEmpty convertedClauses of + Nothing -> + throwConvert + (ConvertUnsupportedTopLevelBinding region "empty match group") + Just clausePairs -> do + expressionValue <- + mkConvExpr + region + ( ClausesF + ( fmap + (\(clauseValue, rhsExpressionValue) -> (clausePatterns clauseValue, rhsExpressionValue)) + (NonEmpty.toList clausePairs) + ) + ) + pure (fmap fst clausePairs, expressionValue) + +convertSimpleSourceClause :: + Env -> + Maybe SourceRegion -> + Match GhcPs (LHsExpr GhcPs) -> + ConvM (Clause, Expr) +convertSimpleSourceClause env region matchValue = + convertSimplePatterns env region (unLoc (m_pats matchValue)) + where + convertSimplePatterns currentEnv currentRegion = \case + [] -> do + (rhsValue, expressionValue) <- + convertSourceRhs currentEnv (m_grhss matchValue) + pure (Clause [] rhsValue, expressionValue) + patternValue : remainingPatterns -> do + childScope <- freshChildScope + (convertedPattern, binderAnn, remainingClause, bodyExpression) <- + withScope childScope $ do + convertedPattern <- convertPat patternValue + case simplePatternBinderAnn convertedPattern of + Nothing -> + throwConvert + (ConvertUnsupportedPattern Nothing PatOpaqueExtension) + Just binderAnn -> do + recordLambdaSite binderAnn + (remainingClause, bodyExpression) <- + convertSimplePatterns + (extendEnv currentEnv [binderAnn]) + Nothing + remainingPatterns + pure + ( convertedPattern, + binderAnn, + remainingClause, + bodyExpression + ) + lambdaExpression <- + mkConvExpr currentRegion (LamF binderAnn bodyExpression) + pure + ( remainingClause + { clausePatterns = + convertedPattern : clausePatterns remainingClause + }, + lambdaExpression + ) + +convertSourceClause :: + Env -> + Match GhcPs (LHsExpr GhcPs) -> + ConvM (Clause, Expr) +convertSourceClause env matchValue = do + let patternValues = unLoc (m_pats matchValue) + binderNames <- + concat <$> traverse collectResolvedPatternNames patternValues + if null binderNames + then do + convertedPatterns <- traverse convertPat patternValues + (rhsValue, expressionValue) <- + convertSourceRhs env (m_grhss matchValue) + pure (Clause convertedPatterns rhsValue, expressionValue) + else do + childScope <- freshChildScope + withScope childScope $ do + convertedPatterns <- traverse convertPat patternValues + let extendedEnv = + extendEnv env (concatMap patBinders convertedPatterns) + (rhsValue, expressionValue) <- + convertSourceRhs extendedEnv (m_grhss matchValue) + pure (Clause convertedPatterns rhsValue, expressionValue) + +convertSourceRhs :: + Env -> + GRHSs GhcPs (LHsExpr GhcPs) -> + ConvM (Rhs, Expr) +convertSourceRhs env grhssValue = do + let rhsRegion = + sourceRegionFromSrcSpan + (getLocA (NonEmpty.head (grhssGRHSs grhssValue))) + maybeConvertedBinds <- + convertLocalBinds rhsRegion env (grhssLocalBinds grhssValue) + let rhsEnv = maybe env clbEnv maybeConvertedBinds + maybeBindingGroup = clbGroup <$> maybeConvertedBinds + convertAtBindingScope :: ConvM converted -> ConvM converted + convertAtBindingScope = + maybe id (withScope . clbScope) maybeConvertedBinds + case grhssGRHSs grhssValue of + locatedGrhs :| [] + | GRHS _ [] bodyValue <- unLoc locatedGrhs -> do + bodyExpression <- + convertAtBindingScope (convertLocatedExpr rhsEnv bodyValue) + expressionValue <- + attachBindingGroup maybeConvertedBinds bodyExpression + pure + ( UnguardedRhs bodyExpression maybeBindingGroup, + expressionValue + ) + grhsAlternatives -> do + guardedAlternatives <- + convertAtBindingScope + (traverse (convertGuardedAlt rhsEnv) grhsAlternatives) + case guardedAlternatives of + GuardedAltF [] bodyExpression :| [] -> do + expressionValue <- + attachBindingGroup maybeConvertedBinds bodyExpression + pure + ( UnguardedRhs bodyExpression maybeBindingGroup, + expressionValue + ) + guardedValues -> do + guardedExpression <- + mkConvExpr rhsRegion (GuardedF (NonEmpty.toList guardedValues)) + expressionValue <- + attachBindingGroup maybeConvertedBinds guardedExpression + pure + ( GuardedRhs guardedValues maybeBindingGroup, + expressionValue + ) + +convertLambdaLikeMatchGroup :: Env -> Maybe SourceRegion -> MatchGroup GhcPs (LHsExpr GhcPs) -> ConvM ConvExpr +convertLambdaLikeMatchGroup env region = \case + MG {mg_alts = alternativesValue} -> + case unLoc alternativesValue of + [matchValue] + | Just binderNames <- simpleLambdaBinderNames (unLoc matchValue) -> + convertLambdaBinders env region binderNames (m_grhss (unLoc matchValue)) + matchValues -> + convertClauses env region matchValues + +convertClauses :: Env -> Maybe SourceRegion -> [LMatch GhcPs (LHsExpr GhcPs)] -> ConvM ConvExpr +convertClauses env region matchValues = do + clauseValues <- traverse (convertClause env . unLoc) matchValues + mkConvExpr region (ClausesF clauseValues) + +convertClause :: Env -> Match GhcPs (LHsExpr GhcPs) -> ConvM ([HsPatF], ConvExpr) +convertClause env matchValue = do + let patternValues = unLoc (m_pats matchValue) + binderNames <- + concat <$> traverse collectResolvedPatternNames patternValues + if null binderNames + then do + clausePatterns <- traverse convertPat patternValues + bodyExpr <- convertGRHSs env (m_grhss matchValue) + pure (clausePatterns, bodyExpr) + else do + childScope <- freshChildScope + withScope childScope $ do + clausePatterns <- traverse convertPat patternValues + let extendedEnv = extendEnv env (concatMap patBinders clausePatterns) + bodyExpr <- convertGRHSs extendedEnv (m_grhss matchValue) + pure (clausePatterns, bodyExpr) + +convertLambdaBinders :: Env -> Maybe SourceRegion -> [RdrName] -> GRHSs GhcPs (LHsExpr GhcPs) -> ConvM ConvExpr +convertLambdaBinders env region binderNames grhssValue = + case binderNames of + [] -> + convertGRHSs env grhssValue + binderName : remainingNames -> do + childScope <- freshChildScope + (binderAnn, bodyExpr) <- + withScope childScope $ do + binderAnn <- freshBinderAnn binderName + recordLambdaSite binderAnn + bodyExpr <- + convertLambdaBinders + (extendEnv env [binderAnn]) + Nothing + remainingNames + grhssValue + pure (binderAnn, bodyExpr) + mkConvExpr region (LamF binderAnn bodyExpr) + +convertCaseAlternatives :: Env -> MatchGroup GhcPs (LHsExpr GhcPs) -> ConvM [(HsPatF, ConvExpr)] +convertCaseAlternatives env = \case + MG {mg_alts = alternativesValue} -> + traverse (convertCaseAlternative env . unLoc) (unLoc alternativesValue) + +convertCaseAlternative :: Env -> Match GhcPs (LHsExpr GhcPs) -> ConvM (HsPatF, ConvExpr) +convertCaseAlternative env matchValue = + case unLoc (m_pats matchValue) of + [patternValue] -> do + childScope <- freshChildScope + withScope childScope $ do + casePattern <- convertPat patternValue + let extendedEnv = extendEnv env (patBinders casePattern) + rhsExpr <- convertGRHSs extendedEnv (m_grhss matchValue) + pure (casePattern, rhsExpr) + _ -> + throwUnsupportedExpression Nothing OpaqueCaseAlternative + +convertGRHSs :: Env -> GRHSs GhcPs (LHsExpr GhcPs) -> ConvM ConvExpr +convertGRHSs env = + fmap snd . convertSourceRhs env + +convertGuardedAlt :: Env -> LGRHS GhcPs (LHsExpr GhcPs) -> ConvM (GuardedAltF ConvExpr) +convertGuardedAlt env grhsValue = + case unLoc grhsValue of + GRHS _ guardValues bodyValue -> do + (guardStatements, bodyExpr) <- + convertGuardedAltBody env guardValues bodyValue + pure + GuardedAltF + { gaGuards = guardStatements, + gaBody = bodyExpr + } + +convertGuardedAltBody :: + Env -> + [GuardLStmt GhcPs] -> + LHsExpr GhcPs -> + ConvM ([HsGuardStmtF ConvExpr], ConvExpr) +convertGuardedAltBody env guardValues bodyValue = + case guardValues of + [] -> do + bodyExpr <- convertLocatedExpr env bodyValue + pure ([], bodyExpr) + guardValue : remainingValues -> + case unLoc guardValue of + BodyStmt _ exprValue _ _ -> do + guardExpr <- convertLocatedExpr env exprValue + prependGuardStatement (GuardBoolF guardExpr) + <$> convertGuardedAltBody env remainingValues bodyValue + LastStmt _ exprValue _ _ -> do + guardExpr <- convertLocatedExpr env exprValue + prependGuardStatement (GuardBoolF guardExpr) + <$> convertGuardedAltBody env remainingValues bodyValue + BindStmt _ patternValue rhsValue -> do + rhsExpr <- convertLocatedExpr env rhsValue + binderNames <- collectResolvedPatternNames patternValue + if null binderNames + then do + bindPattern <- convertPat patternValue + prependGuardStatement (GuardPatF bindPattern rhsExpr) + <$> convertGuardedAltBody env remainingValues bodyValue + else do + childScope <- freshChildScope + withScope childScope $ do + bindPattern <- convertPat patternValue + let extendedEnv = extendEnv env (patBinders bindPattern) + prependGuardStatement (GuardPatF bindPattern rhsExpr) + <$> convertGuardedAltBody extendedEnv remainingValues bodyValue + LetStmt _ localBindsValue -> + convertLocalBinds + (sourceRegionFromSrcSpan (getLocA guardValue)) + env + localBindsValue + >>= \case + Nothing -> + throwUnsupportedExpression + (sourceRegionFromSrcSpan (getLocA guardValue)) + OpaqueEmptyLocalBinds + Just convertedBinds -> + prependGuardStatement + (GuardLetF (clbRecursion convertedBinds) (clbBindings convertedBinds)) + <$> withScope + (clbScope convertedBinds) + (convertGuardedAltBody (clbEnv convertedBinds) remainingValues bodyValue) + ParStmt {} -> + throwUnsupportedExpression + (sourceRegionFromSrcSpan (getLocA guardValue)) + OpaqueParallelStatement + TransStmt {} -> + throwUnsupportedExpression + (sourceRegionFromSrcSpan (getLocA guardValue)) + OpaqueTransformStatement + RecStmt {} -> + throwUnsupportedExpression + (sourceRegionFromSrcSpan (getLocA guardValue)) + OpaqueRecursiveStatement + +prependGuardStatement :: + HsGuardStmtF ConvExpr -> + ([HsGuardStmtF ConvExpr], ConvExpr) -> + ([HsGuardStmtF ConvExpr], ConvExpr) +prependGuardStatement guardStatement (guardStatements, bodyExpr) = + (guardStatement : guardStatements, bodyExpr) + +convertStatements :: Env -> [ExprLStmt GhcPs] -> ConvM [HsStmtF ConvExpr] +convertStatements env = \case + [] -> + pure [] + statementValue : remainingValues -> + case unLoc statementValue of + BindStmt _ patternValue rhsValue -> do + rhsExpr <- convertLocatedExpr env rhsValue + binderNames <- collectResolvedPatternNames patternValue + if null binderNames + then do + bindPattern <- convertPat patternValue + (BindStmtF bindPattern rhsExpr :) + <$> convertStatements env remainingValues + else do + childScope <- freshChildScope + withScope childScope $ do + bindPattern <- convertPat patternValue + let extendedEnv = extendEnv env (patBinders bindPattern) + (BindStmtF bindPattern rhsExpr :) + <$> convertStatements extendedEnv remainingValues + BodyStmt _ exprValue _ _ -> do + bodyExpr <- convertLocatedExpr env exprValue + (BodyStmtF bodyExpr :) <$> convertStatements env remainingValues + LastStmt _ exprValue _ _ -> do + bodyExpr <- convertLocatedExpr env exprValue + pure [BodyStmtF bodyExpr] + LetStmt _ localBindsValue -> + convertLocalBinds + (sourceRegionFromSrcSpan (getLocA statementValue)) + env + localBindsValue + >>= \case + Nothing -> + throwUnsupportedExpression + (sourceRegionFromSrcSpan (getLocA statementValue)) + OpaqueEmptyLocalBinds + Just convertedBinds -> + (LetStmtF (clbRecursion convertedBinds) (clbBindings convertedBinds) :) + <$> withScope + (clbScope convertedBinds) + (convertStatements (clbEnv convertedBinds) remainingValues) + ParStmt {} -> + throwUnsupportedExpression + (sourceRegionFromSrcSpan (getLocA statementValue)) + OpaqueParallelStatement + TransStmt {} -> + throwUnsupportedExpression + (sourceRegionFromSrcSpan (getLocA statementValue)) + OpaqueTransformStatement + RecStmt {} -> + throwUnsupportedExpression + (sourceRegionFromSrcSpan (getLocA statementValue)) + OpaqueRecursiveStatement + +convertLocalBinds :: + Maybe SourceRegion -> + Env -> + HsLocalBinds GhcPs -> + ConvM (Maybe ConvertedLocalBinds) +convertLocalBinds region env = \case + EmptyLocalBinds _ -> + pure Nothing + HsValBinds _ valBindsValue -> + convertValBinds region env valBindsValue + HsIPBinds {} -> + throwUnsupportedExpression region OpaqueImplicitParameterBinds + +convertValBinds :: + Maybe SourceRegion -> + Env -> + HsValBindsLR GhcPs GhcPs -> + ConvM (Maybe ConvertedLocalBinds) +convertValBinds region env = \case + ValBinds _ bindsValue _ -> do + case NonEmpty.nonEmpty bindsValue of + Nothing -> + pure Nothing + Just (locatedBindValue :| []) -> do + childScope <- freshChildScope + withScope childScope $ do + bindingPatternValue <- localBindPattern locatedBindValue + let binders = patBinders bindingPatternValue + extendedEnv = extendEnv env binders + convertedBinding <- + convertBindingWithPattern extendedEnv bindingPatternValue (unLoc locatedBindValue) + let referencesOwnBinder = + freeScopeSummaryContains + childScope + (exprFreeScopes (cbExpression convertedBinding)) + bindingComponents = + Dependencies.singletonBindingComponent bindingPatternValue referencesOwnBinder + bindingGroup = + BindingGroup childScope bindingComponents (cbBinding convertedBinding :| []) + letRecursionValue = + Dependencies.bindingComponentsRecursion bindingComponents + case bindingPatternValue of + PVarP binderAnn + | letRecursionValue == NonRecursiveBinds -> + recordLetSite binderAnn + _ -> + pure () + pure + ( Just + ConvertedLocalBinds + { clbRecursion = letRecursionValue, + clbScope = childScope, + clbGroup = bindingGroup, + clbBindings = [(bindingPatternValue, cbExpression convertedBinding)], + clbBinders = binders, + clbEnv = extendedEnv + } + ) + Just nonEmptyLocatedBindValues -> do + childScope <- freshChildScope + withScope childScope $ do + bindingGroupId <- freshBindingGroupId + bindPatterns <- + traverse localBindPattern nonEmptyLocatedBindValues + registerBindingOwners bindingGroupId bindPatterns + let binders = + foldMap patBinders bindPatterns + extendedEnv = + extendEnv env binders + indexedBindings = + NonEmpty.zip + (0 :| [1 ..]) + (NonEmpty.zip bindPatterns (fmap unLoc nonEmptyLocatedBindValues)) + convertedBindings <- + traverse + ( \(rowIndex, (bindingPatternValue, bindingValue)) -> + withActiveBindingRow bindingGroupId rowIndex + (convertBindingWithPattern extendedEnv bindingPatternValue bindingValue) + ) + indexedBindings + dependenciesByRow <- + takeBindingDependencies bindingGroupId binders + let bindingRowsNonEmpty = + convertedBindingRows convertedBindings + bindingRows = + NonEmpty.toList bindingRowsNonEmpty + bindingGroup <- + either + (throwConvert . ConvertBindingDependencyFailure) + pure + (mkBindingGroup childScope convertedBindings dependenciesByRow) + let letRecursionValue = + Dependencies.bindingComponentsRecursion (bindingGroupComponents bindingGroup) + case bindingRows of + [(PVarP binderAnn, _)] + | letRecursionValue == NonRecursiveBinds -> + recordLetSite binderAnn + _ -> + pure () + pure + ( Just + ConvertedLocalBinds + { clbRecursion = letRecursionValue, + clbScope = childScope, + clbGroup = bindingGroup, + clbBindings = bindingRows, + clbBinders = binders, + clbEnv = extendedEnv + } + ) + XValBindsLR _ -> + throwUnsupportedExpression region OpaqueExtensionValBinds + +convertTupleArg :: Env -> HsTupArg GhcPs -> ConvM (TupleSlot ConvExpr) +convertTupleArg env = \case + Present _ exprValue -> + TuplePresent <$> convertLocatedExpr env exprValue + Missing _ -> + pure TupleMissing + +flattenOpChain :: + LHsExpr GhcPs -> + LHsExpr GhcPs -> + LHsExpr GhcPs -> + (LHsExpr GhcPs, NonEmpty (LHsExpr GhcPs, LHsExpr GhcPs)) +flattenOpChain leftValue operatorValue rightValue = + let (firstOperand, leftTail) = flattenLocatedOpChain leftValue + (rightHead, rightTail) = flattenLocatedOpChain rightValue + finalPair = (operatorValue, rightHead) + in case leftTail of + [] -> + (firstOperand, finalPair :| rightTail) + firstPair : remainingPairs -> + (firstOperand, firstPair :| (remainingPairs <> (finalPair : rightTail))) + +flattenLocatedOpChain :: + LHsExpr GhcPs -> + (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) +flattenLocatedOpChain locatedExpr = + case unLoc locatedExpr of + OpApp _ leftValue operatorValue rightValue -> + let (firstOperand, leftTail) = flattenLocatedOpChain leftValue + (rightHead, rightTail) = flattenLocatedOpChain rightValue + in (firstOperand, leftTail <> ((operatorValue, rightHead) : rightTail)) + _ -> + (locatedExpr, []) + +convertRecordFields :: Env -> HsRecFields GhcPs (LHsExpr GhcPs) -> ConvM [(NormalizedFieldLabel, ConvExpr)] +convertRecordFields env recordFieldsValue = + traverse + (convertRecordField env . unLoc) + (rec_flds recordFieldsValue) + +convertRecordUpdFields :: + Maybe SourceRegion -> + Env -> + LHsRecUpdFields GhcPs -> + ConvM [(NormalizedFieldLabel, ConvExpr)] +convertRecordUpdFields region env = \case + RegularRecUpdFields {recUpdFields = recordFieldsValue} -> + traverse + (convertRecordField env . unLoc) + recordFieldsValue + OverloadedRecUpdFields {} -> + throwUnsupportedExpression region OpaqueOverloadedRecordUpdate + +convertRecordField :: Env -> HsRecField GhcPs (LHsExpr GhcPs) -> ConvM (NormalizedFieldLabel, ConvExpr) +convertRecordField env fieldBindValue = + case unLoc (hfbLHS fieldBindValue) of + FieldOcc {foLabel = labelValue} -> do + fieldExpr <- + if hfbPun fieldBindValue + then do + variableReference <- resolveVarRef env (unLoc labelValue) + mkConvExpr Nothing (VarF variableReference) + else convertLocatedExpr env (hfbRHS fieldBindValue) + pure + ( normalizeFieldOcc (unLoc labelValue), + fieldExpr + ) + +convertArithSeq :: Env -> ArithSeqInfo GhcPs -> ConvM (NormalizedArithSeq ConvExpr) +convertArithSeq env = \case + From fromValue -> + ArithSeqFrom <$> convertLocatedExpr env fromValue + FromThen fromValue thenValue -> + ArithSeqFromThen + <$> convertLocatedExpr env fromValue + <*> convertLocatedExpr env thenValue + FromTo fromValue toValue -> + ArithSeqFromTo + <$> convertLocatedExpr env fromValue + <*> convertLocatedExpr env toValue + FromThenTo fromValue thenValue toValue -> + ArithSeqFromThenTo + <$> convertLocatedExpr env fromValue + <*> convertLocatedExpr env thenValue + <*> convertLocatedExpr env toValue diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/FreeScopes.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/FreeScopes.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/FreeScopes.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Pale.Ghc.Expr.Convert.FreeScopes + ( ScopeAlgebra (..), + freeScopesExpr, + ) +where + +import Control.Monad (foldM) +import Data.Kind (Type) +import Moonlight.Pale.Ghc.Expr.Scope +import Moonlight.Pale.Ghc.Expr.Syntax + +type ScopeAlgebra :: Type -> Type +data ScopeAlgebra failure = ScopeAlgebra + { saScopeDepth :: ScopeId -> Either failure Int, + saBinderIntro :: BinderAnn -> Either failure ScopeId + } + +mergeScopeSummary :: ScopeAlgebra failure -> FreeScopeSummary -> FreeScopeSummary -> Either failure FreeScopeSummary +mergeScopeSummary scopeAlgebra = + mergeFreeScopeSummaryByEither (saScopeDepth scopeAlgebra) + +mergeScopeSummaries :: ScopeAlgebra failure -> [FreeScopeSummary] -> Either failure FreeScopeSummary +mergeScopeSummaries scopeAlgebra = + foldM (mergeScopeSummary scopeAlgebra) emptyFreeScopeSummary + +deleteBinderScope :: ScopeAlgebra failure -> BinderAnn -> FreeScopeSummary -> Either failure FreeScopeSummary +deleteBinderScope scopeAlgebra binderAnn summaryValue = do + binderScope <- saBinderIntro scopeAlgebra binderAnn + pure (deleteFreeScopeSummary binderScope summaryValue) + +deletePatBinderScopes :: ScopeAlgebra failure -> HsPatF -> FreeScopeSummary -> Either failure FreeScopeSummary +deletePatBinderScopes scopeAlgebra patternValue summaryValue = + foldM (\acc binderAnn -> deleteBinderScope scopeAlgebra binderAnn acc) summaryValue (patBinders patternValue) + +freeScopesExpr :: ScopeAlgebra failure -> HsExprF Expr -> Either failure FreeScopeSummary +freeScopesExpr scopeAlgebra nodeValue = + case nodeValue of + VarF (GlobalName _) -> + pure emptyFreeScopeSummary + VarF (LocalName binderAnn) -> + singletonFreeScopeSummary <$> saBinderIntro scopeAlgebra binderAnn + LamF binderAnn bodyExpr -> + deleteBinderScope scopeAlgebra binderAnn (exprFreeScopes bodyExpr) + LetF letRecursion bindingValues bodyExpr -> + freeScopesLet scopeAlgebra letRecursion bindingValues (exprFreeScopes bodyExpr) + CaseF scrutineeExpr branchValues -> do + branchFree <- traverse (freeScopesCaseAlternative scopeAlgebra) branchValues >>= mergeScopeSummaries scopeAlgebra + mergeScopeSummary scopeAlgebra (exprFreeScopes scrutineeExpr) branchFree + DoF statementValues -> + freeScopesDo scopeAlgebra statementValues + GuardedF guardedAlts -> + traverse (freeScopesGuardedAlt scopeAlgebra) guardedAlts >>= mergeScopeSummaries scopeAlgebra + MultiIfF guardedAlts -> + traverse (freeScopesGuardedAlt scopeAlgebra) guardedAlts >>= mergeScopeSummaries scopeAlgebra + ClausesF clauseValues -> + traverse (freeScopesClause scopeAlgebra) clauseValues >>= mergeScopeSummaries scopeAlgebra + _ -> + foldM + (\acc childExpr -> mergeScopeSummary scopeAlgebra acc (exprFreeScopes childExpr)) + emptyFreeScopeSummary + nodeValue + +freeScopesLet :: + ScopeAlgebra failure -> + LetRecursion -> + [(HsPatF, Expr)] -> + FreeScopeSummary -> + Either failure FreeScopeSummary +freeScopesLet scopeAlgebra letRecursion bindingValues bodyFree0 = do + bodyFree <- + foldM + (\acc (rowPattern, _) -> deletePatBinderScopes scopeAlgebra rowPattern acc) + bodyFree0 + bindingValues + rhsFree <- + case letRecursion of + NonRecursiveBinds -> + foldM + (\acc (_, rhsExpr) -> mergeScopeSummary scopeAlgebra acc (exprFreeScopes rhsExpr)) + emptyFreeScopeSummary + bindingValues + AcyclicDependentBinds -> + freeScopesMutuallyVisibleBindings scopeAlgebra bindingValues + RecursiveBinds -> + freeScopesMutuallyVisibleBindings scopeAlgebra bindingValues + mergeScopeSummary scopeAlgebra rhsFree bodyFree + +freeScopesMutuallyVisibleBindings :: + ScopeAlgebra failure -> + [(HsPatF, Expr)] -> + Either failure FreeScopeSummary +freeScopesMutuallyVisibleBindings scopeAlgebra bindingValues = do + aggregateRhsFree <- + mergeScopeSummaries + scopeAlgebra + (fmap (exprFreeScopes . snd) bindingValues) + foldM + (\acc (rowPattern, _) -> deletePatBinderScopes scopeAlgebra rowPattern acc) + aggregateRhsFree + bindingValues + +freeScopesCaseAlternative :: ScopeAlgebra failure -> (HsPatF, Expr) -> Either failure FreeScopeSummary +freeScopesCaseAlternative scopeAlgebra (casePattern, branchExpr) = + deletePatBinderScopes scopeAlgebra casePattern (exprFreeScopes branchExpr) + +freeScopesClause :: ScopeAlgebra failure -> ([HsPatF], Expr) -> Either failure FreeScopeSummary +freeScopesClause scopeAlgebra (clausePatterns, bodyExpr) = + foldM (flip (deletePatBinderScopes scopeAlgebra)) (exprFreeScopes bodyExpr) clausePatterns + +freeScopesDo :: ScopeAlgebra failure -> [HsStmtF Expr] -> Either failure FreeScopeSummary +freeScopesDo scopeAlgebra = \case + [] -> + pure emptyFreeScopeSummary + statementValue : remainingValues -> do + laterFree <- freeScopesDo scopeAlgebra remainingValues + freeScopesStmt scopeAlgebra statementValue laterFree + +freeScopesStmt :: ScopeAlgebra failure -> HsStmtF Expr -> FreeScopeSummary -> Either failure FreeScopeSummary +freeScopesStmt scopeAlgebra statementValue laterFree = + case statementValue of + BindStmtF bindPattern rhsExpr -> do + visibleLaterFree <- deletePatBinderScopes scopeAlgebra bindPattern laterFree + mergeScopeSummary scopeAlgebra (exprFreeScopes rhsExpr) visibleLaterFree + BodyStmtF exprValue -> + mergeScopeSummary scopeAlgebra (exprFreeScopes exprValue) laterFree + LetStmtF letRecursion bindingValues -> + freeScopesLet scopeAlgebra letRecursion bindingValues laterFree + +freeScopesGuardedAlt :: ScopeAlgebra failure -> GuardedAltF Expr -> Either failure FreeScopeSummary +freeScopesGuardedAlt scopeAlgebra guardedAlt = + freeScopesGuardStmts scopeAlgebra (gaGuards guardedAlt) (exprFreeScopes (gaBody guardedAlt)) + +freeScopesGuardStmts :: + ScopeAlgebra failure -> + [HsGuardStmtF Expr] -> + FreeScopeSummary -> + Either failure FreeScopeSummary +freeScopesGuardStmts scopeAlgebra guardStatements bodyFree = + case guardStatements of + [] -> + pure bodyFree + guardStatement : remainingStatements -> do + laterFree <- freeScopesGuardStmts scopeAlgebra remainingStatements bodyFree + freeScopesGuardStmt scopeAlgebra guardStatement laterFree + +freeScopesGuardStmt :: + ScopeAlgebra failure -> + HsGuardStmtF Expr -> + FreeScopeSummary -> + Either failure FreeScopeSummary +freeScopesGuardStmt scopeAlgebra guardStatement laterFree = + case guardStatement of + GuardBoolF exprValue -> + mergeScopeSummary scopeAlgebra (exprFreeScopes exprValue) laterFree + GuardPatF guardPattern rhsExpr -> do + visibleLaterFree <- deletePatBinderScopes scopeAlgebra guardPattern laterFree + mergeScopeSummary scopeAlgebra (exprFreeScopes rhsExpr) visibleLaterFree + GuardLetF letRecursion bindingValues -> + freeScopesLet scopeAlgebra letRecursion bindingValues laterFree diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Metrics.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Metrics.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Metrics.hs @@ -0,0 +1,147 @@ +module Moonlight.Pale.Ghc.Expr.Convert.Metrics + ( ConvertedModuleMetrics (..), + convertedModuleMetrics, + ) +where + +import Data.Kind (Type) +import Moonlight.Pale.Ghc.Expr.Convert.Coalgebra + ( ConvertedBindingMetrics, + ConvertedInstanceDeclaration (..), + ConvertedModule (..), + InstanceMethodSection (..), + ModuleDeclaration (..), + convertedBindingGlobalVarRefCount, + convertedBindingLocalVarRefCount, + convertedBindingMaxFreeScopeCount, + convertedBindingScopedExprCount, + convertedValueBindingMetrics, + ) +import Moonlight.Pale.Ghc.Expr.Scope + ( scopeObservedCount, + ) + +type ConvertedModuleMetrics :: Type +data ConvertedModuleMetrics = ConvertedModuleMetrics + { cmmBindingCount :: !Int, + cmmInstanceDeclarationCount :: !Int, + cmmTraversableInstanceMethodCount :: !Int, + cmmObstructedInstanceMethodCount :: !Int, + cmmObservedContextCount :: !Int, + cmmLambdaSiteCount :: !Int, + cmmLetSiteCount :: !Int, + cmmScopedExprCount :: !Int, + cmmGlobalVarRefCount :: !Int, + cmmLocalVarRefCount :: !Int, + cmmMaxFreeScopeCount :: !Int + } + deriving stock (Eq, Ord, Show) + +type ModuleMetricSection :: Type +data ModuleMetricSection = ModuleMetricSection + { moduleMetricBindingCount :: !Int, + moduleMetricInstanceDeclarationCount :: !Int, + moduleMetricTraversableInstanceMethodCount :: !Int, + moduleMetricObstructedInstanceMethodCount :: !Int, + moduleMetricExpressionSection :: !ConvertedBindingMetrics + } + +instance Semigroup ModuleMetricSection where + leftSection <> rightSection = + ModuleMetricSection + { moduleMetricBindingCount = + moduleMetricBindingCount leftSection + + moduleMetricBindingCount rightSection, + moduleMetricInstanceDeclarationCount = + moduleMetricInstanceDeclarationCount leftSection + + moduleMetricInstanceDeclarationCount rightSection, + moduleMetricTraversableInstanceMethodCount = + moduleMetricTraversableInstanceMethodCount leftSection + + moduleMetricTraversableInstanceMethodCount rightSection, + moduleMetricObstructedInstanceMethodCount = + moduleMetricObstructedInstanceMethodCount leftSection + + moduleMetricObstructedInstanceMethodCount rightSection, + moduleMetricExpressionSection = + moduleMetricExpressionSection leftSection + <> moduleMetricExpressionSection rightSection + } + +instance Monoid ModuleMetricSection where + mempty = + ModuleMetricSection + { moduleMetricBindingCount = 0, + moduleMetricInstanceDeclarationCount = 0, + moduleMetricTraversableInstanceMethodCount = 0, + moduleMetricObstructedInstanceMethodCount = 0, + moduleMetricExpressionSection = mempty + } + +convertedModuleMetrics :: + ConvertedModule -> + ConvertedModuleMetrics +convertedModuleMetrics convertedModule = + let scopeIndex = cmScopeIndex convertedModule + metricSection = + foldMap declarationMetricSection (cmDeclarations convertedModule) + expressionMetrics = + moduleMetricExpressionSection metricSection + in + ConvertedModuleMetrics + { cmmBindingCount = moduleMetricBindingCount metricSection, + cmmInstanceDeclarationCount = + moduleMetricInstanceDeclarationCount metricSection, + cmmTraversableInstanceMethodCount = + moduleMetricTraversableInstanceMethodCount metricSection, + cmmObstructedInstanceMethodCount = + moduleMetricObstructedInstanceMethodCount metricSection, + cmmObservedContextCount = scopeObservedCount scopeIndex, + cmmLambdaSiteCount = length (cmLambdaSites convertedModule), + cmmLetSiteCount = length (cmLetSites convertedModule), + cmmScopedExprCount = + convertedBindingScopedExprCount expressionMetrics, + cmmGlobalVarRefCount = + convertedBindingGlobalVarRefCount expressionMetrics, + cmmLocalVarRefCount = + convertedBindingLocalVarRefCount expressionMetrics, + cmmMaxFreeScopeCount = + convertedBindingMaxFreeScopeCount expressionMetrics + } + +declarationMetricSection :: + ModuleDeclaration -> + ModuleMetricSection +declarationMetricSection = \case + ValueDeclaration bindingValue -> + mempty + { moduleMetricBindingCount = 1, + moduleMetricExpressionSection = + convertedValueBindingMetrics bindingValue + } + InstanceDeclarationNode instanceDeclaration -> + mempty + { moduleMetricInstanceDeclarationCount = 1 + } + <> foldMap + instanceMethodMetricSection + (convertedInstanceMethods instanceDeclaration) + TypeSignatureDeclaration _ -> + mempty + FixityDeclarationNode _ -> + mempty + OpaqueDeclaration {} -> + mempty + +instanceMethodMetricSection :: + InstanceMethodSection -> + ModuleMetricSection +instanceMethodMetricSection = \case + TraversableInstanceMethod bindingValue -> + mempty + { moduleMetricTraversableInstanceMethodCount = 1, + moduleMetricExpressionSection = + convertedValueBindingMetrics bindingValue + } + ObstructedInstanceMethod _ -> + mempty + { moduleMetricObstructedInstanceMethodCount = 1 + } diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Obstruction.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Obstruction.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Obstruction.hs @@ -0,0 +1,156 @@ +module Moonlight.Pale.Ghc.Expr.Convert.Obstruction + ( UnsupportedDeclarationTag (..), + InstanceMethodObstructionCause (..), + InstanceMethodObstruction (..), + RecordWildcardResolutionFailure (..), + ConvertObstruction (..), + recoverableInstanceMethodObstruction, + ) +where + +import Data.Kind (Type) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Name.Reader (RdrName, rdrNameOcc) +import Moonlight.Core (BinderId) +import Moonlight.Pale.Ghc.Expr.Convert.Dependencies + ( BindingDependencyFailure, + ) +import Moonlight.Pale.Ghc.Expr.Scope + ( ScopeId, + ScopeIdFailure, + ScopeIndexFailure, + ) +import Moonlight.Pale.Ghc.Expr.Syntax (SourceRegion) +import Moonlight.Pale.Ghc.Expr.Opaque (HsOpaqueTag, HsPatOpaqueTag) +import Moonlight.Pale.Ghc.ModuleSurface (GhcParseFailure) + +type UnsupportedDeclarationTag :: Type +data UnsupportedDeclarationTag + = UnsupportedTypeOrClassDeclaration + | UnsupportedTypeFamilyInstanceDeclaration + | UnsupportedDataFamilyInstanceDeclaration + | UnsupportedDerivingDeclaration + | UnsupportedKindSignatureDeclaration + | UnsupportedDefaultDeclaration + | UnsupportedForeignDeclaration + | UnsupportedWarningDeclaration + | UnsupportedAnnotationDeclaration + | UnsupportedRuleDeclaration + | UnsupportedSpliceDeclaration + | UnsupportedDocumentationDeclaration + | UnsupportedRoleAnnotationDeclaration + | UnsupportedPatternSynonymSignature + | UnsupportedClassOperationSignature + | UnsupportedInlineSignature + | UnsupportedSpecializationSignature + | UnsupportedExpressionSpecializationSignature + | UnsupportedInstanceSpecializationSignature + | UnsupportedMinimalSignature + | UnsupportedCostCentreSignature + | UnsupportedCompleteMatchSignature + deriving stock (Eq, Ord, Show, Enum, Bounded) + +type InstanceMethodObstructionCause :: Type +data InstanceMethodObstructionCause + = InstanceMethodUnsupportedBinding !(Maybe SourceRegion) !String + | InstanceMethodUnsupportedExpression !(Maybe SourceRegion) !HsOpaqueTag + | InstanceMethodUnsupportedPattern !(Maybe SourceRegion) !HsPatOpaqueTag + deriving stock (Eq, Ord, Show) + +type InstanceMethodObstruction :: Type +data InstanceMethodObstruction = InstanceMethodObstruction + { instanceMethodObstructionRegion :: !(Maybe SourceRegion), + instanceMethodObstructionCause :: !InstanceMethodObstructionCause + } + deriving stock (Eq, Ord, Show) + +type RecordWildcardResolutionFailure :: Type +data RecordWildcardResolutionFailure + = RecordWildcardConstructorUnavailable !RdrName + | RecordWildcardConstructorAmbiguous !RdrName + deriving stock (Eq, Ord) + +instance Show RecordWildcardResolutionFailure where + show = \case + RecordWildcardConstructorUnavailable constructorName -> + "RecordWildcardConstructorUnavailable " + <> occNameString (rdrNameOcc constructorName) + RecordWildcardConstructorAmbiguous constructorName -> + "RecordWildcardConstructorAmbiguous " + <> occNameString (rdrNameOcc constructorName) + +type ConvertObstruction :: Type +data ConvertObstruction + = ConvertParseFailure !GhcParseFailure + | ConvertScopeIndexFailure !ScopeIndexFailure + | ConvertFreshScopeIdFailure !Int !ScopeIdFailure + | ConvertMissingScopeDepth !ScopeId + | ConvertMissingBinderIntro !BinderId + | ConvertMissingScopeSummaryDepth !ScopeId + | ConvertBindingDependencyFailure !BindingDependencyFailure + | ConvertUnsupportedTopLevelBinding !(Maybe SourceRegion) !String + | ConvertDeclarationSourceUnavailable !(Maybe SourceRegion) !UnsupportedDeclarationTag + | ConvertInstanceDeclarationSourceUnavailable !(Maybe SourceRegion) + | ConvertRecordWildcardResolutionUnavailable !SourceRegion !RecordWildcardResolutionFailure + | ConvertRecordWildcardPositionInvalid !SourceRegion !Int !Int + | ConvertRecordWildcardRegionUnavailable !(Maybe SourceRegion) + | ConvertEmptyTypeSignature !(Maybe SourceRegion) + | ConvertEmptyFixityDeclaration !(Maybe SourceRegion) + | ConvertUnsupportedExpression !(Maybe SourceRegion) !HsOpaqueTag + | ConvertUnsupportedPattern !(Maybe SourceRegion) !HsPatOpaqueTag + deriving stock (Eq, Ord, Show) + +recoverableInstanceMethodObstruction :: + Maybe SourceRegion -> + ConvertObstruction -> + Maybe InstanceMethodObstruction +recoverableInstanceMethodObstruction methodRegion = \case + ConvertUnsupportedTopLevelBinding obstructionRegion bindingShape -> + Just + InstanceMethodObstruction + { instanceMethodObstructionRegion = methodRegion, + instanceMethodObstructionCause = + InstanceMethodUnsupportedBinding obstructionRegion bindingShape + } + ConvertUnsupportedExpression obstructionRegion expressionTag -> + Just + InstanceMethodObstruction + { instanceMethodObstructionRegion = methodRegion, + instanceMethodObstructionCause = + InstanceMethodUnsupportedExpression obstructionRegion expressionTag + } + ConvertUnsupportedPattern obstructionRegion patternTag -> + Just + InstanceMethodObstruction + { instanceMethodObstructionRegion = methodRegion, + instanceMethodObstructionCause = + InstanceMethodUnsupportedPattern obstructionRegion patternTag + } + ConvertParseFailure {} -> + Nothing + ConvertScopeIndexFailure {} -> + Nothing + ConvertFreshScopeIdFailure {} -> + Nothing + ConvertMissingScopeDepth {} -> + Nothing + ConvertMissingBinderIntro {} -> + Nothing + ConvertMissingScopeSummaryDepth {} -> + Nothing + ConvertBindingDependencyFailure {} -> + Nothing + ConvertDeclarationSourceUnavailable {} -> + Nothing + ConvertInstanceDeclarationSourceUnavailable {} -> + Nothing + ConvertRecordWildcardResolutionUnavailable {} -> + Nothing + ConvertRecordWildcardPositionInvalid {} -> + Nothing + ConvertRecordWildcardRegionUnavailable {} -> + Nothing + ConvertEmptyTypeSignature {} -> + Nothing + ConvertEmptyFixityDeclaration {} -> + Nothing diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Pattern.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Pattern.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Pattern.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Pale.Ghc.Expr.Convert.Pattern + ( simpleLambdaBinderNames, + localBindPattern, + bindingHeadPatternFromBind, + normalizeFieldOcc, + simpleLambdaBinderName, + collectPatternNames, + collectResolvedPatternNames, + convertPat, + convertRecPatField, + lossyPat, + convertTupleBoxity + ) +where + +import Control.Applicative ((<|>)) +import Data.Set qualified as Set +import GHC.Hs + ( FieldOcc (..), + GhcPs, + HsBind, + HsBindLR (..), + HsConDetails (..), + HsFieldBind (..), + HsRecField, + HsRecFields (..), + LHsBind, + LHsExpr, + LPat, + Match (..), + Pat (..), + RecFieldsDotDot (..), + ) +import GHC.Hs.Utils (CollectFlag (CollNoDictBinders), collectPatBinders) +import GHC.Parser.Annotation (EpaLocation, getHasLoc, getLocA) +import GHC.Types.Basic (Boxity (..)) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Name.Reader (RdrName, mkRdrUnqual, rdrNameOcc) +import GHC.Types.SrcLoc (GenLocated, unLoc) +import Moonlight.Pale.Ghc.Expr.Convert.Obstruction +import Moonlight.Pale.Ghc.Expr.Convert.State +import Moonlight.Pale.Ghc.Expr.Opaque +import Moonlight.Pale.Ghc.Expr.Syntax + +simpleLambdaBinderNames :: Match GhcPs (LHsExpr GhcPs) -> Maybe [RdrName] +simpleLambdaBinderNames matchValue = + traverse (simpleLambdaBinderName . unLoc) (unLoc (m_pats matchValue)) + +localBindPattern :: LHsBind GhcPs -> ConvM HsPatF +localBindPattern locatedBinding = + bindingHeadPatternFromBind + (sourceRegionFromSrcSpan (getLocA locatedBinding)) + (unLoc locatedBinding) + +bindingHeadPatternFromBind :: + Maybe SourceRegion -> + HsBind GhcPs -> + ConvM HsPatF +bindingHeadPatternFromBind region = \case + FunBind {fun_id = nameValue} -> + PVarP <$> freshBinderAnn (unLoc nameValue) + PatBind {pat_lhs = patternValue} -> + convertPat patternValue + VarBind {var_id = nameValue} -> + PVarP <$> freshBinderAnn nameValue + PatSynBind {} -> + throwUnsupportedExpression region OpaquePatternSynonymBind + +normalizeFieldOcc :: RdrName -> NormalizedFieldLabel +normalizeFieldOcc rdrName = + NormalizedFieldLabel + { nflSelector = occNameString (rdrNameOcc rdrName), + nflAllowsDuplicateRecordFields = False, + nflHasSelector = True + } + +simpleLambdaBinderName :: Pat GhcPs -> Maybe RdrName +simpleLambdaBinderName = \case + VarPat _ nameValue -> Just (unLoc nameValue) + ParPat _ patternValue -> simpleLambdaBinderName (unLoc patternValue) + BangPat _ patternValue -> simpleLambdaBinderName (unLoc patternValue) + LazyPat _ patternValue -> simpleLambdaBinderName (unLoc patternValue) + SigPat _ patternValue _ -> simpleLambdaBinderName (unLoc patternValue) + _ -> Nothing + +collectPatternNames :: LPat GhcPs -> [RdrName] +collectPatternNames = collectPatBinders CollNoDictBinders + +collectResolvedPatternNames :: LPat GhcPs -> ConvM [RdrName] +collectResolvedPatternNames patternValue = + (collectPatternNames patternValue <>) + <$> collectRecordWildcardBinderNames patternValue + +collectRecordWildcardBinderNames :: LPat GhcPs -> ConvM [RdrName] +collectRecordWildcardBinderNames patternValue = + case unLoc patternValue of + ParPat _ innerValue -> + collectRecordWildcardBinderNames innerValue + BangPat _ innerValue -> + collectRecordWildcardBinderNames innerValue + LazyPat _ innerValue -> + collectRecordWildcardBinderNames innerValue + AsPat _ _ innerValue -> + collectRecordWildcardBinderNames innerValue + TuplePat _ componentValues _ -> + concat <$> traverse collectRecordWildcardBinderNames componentValues + ListPat _ componentValues -> + concat <$> traverse collectRecordWildcardBinderNames componentValues + ConPat {pat_con = constructorValue, pat_args = argumentsValue} -> + case argumentsValue of + PrefixCon argumentValues -> + concat <$> traverse collectRecordWildcardBinderNames argumentValues + InfixCon leftValue rightValue -> + concat + <$> traverse + collectRecordWildcardBinderNames + [leftValue, rightValue] + RecCon recordFieldsValue -> do + nestedWildcardBinders <- + concat + <$> traverse + (collectRecordWildcardBinderNames . hfbRHS . unLoc) + (rec_flds recordFieldsValue) + currentWildcardBinders <- + case rec_dotdot recordFieldsValue of + Nothing -> + pure [] + Just locatedDotDot -> do + wildcardRegion <- + recordWildcardRegion patternValue locatedDotDot + resolveRecordWildcardBinderNames + wildcardRegion + (unLoc constructorValue) + (fmap (recordFieldName . unLoc) (rec_flds recordFieldsValue)) + pure (currentWildcardBinders <> nestedWildcardBinders) + _ -> + pure [] + +convertPat :: LPat GhcPs -> ConvM HsPatF +convertPat patternValue = + case unLoc patternValue of + VarPat _ nameValue -> + PVarP <$> freshBinderAnn (unLoc nameValue) + WildPat {} -> + pure PWildP + ParPat _ innerValue -> + PParP <$> convertPat innerValue + BangPat _ innerValue -> + PBangP <$> convertPat innerValue + LazyPat _ innerValue -> + PLazyP <$> convertPat innerValue + AsPat _ nameValue innerValue -> + PAsP <$> freshBinderAnn (unLoc nameValue) <*> convertPat innerValue + TuplePat _ componentValues boxity -> + PTupleP (convertTupleBoxity boxity) <$> traverse convertPat componentValues + ListPat _ componentValues -> + PListP <$> traverse convertPat componentValues + LitPat _ literalValue -> + pure (PLitP (normalizeHsLit literalValue)) + NPat _ overLitValue Nothing _ -> + pure (POverLitP (normalizeHsOverLit (unLoc overLitValue))) + NPat {} -> + lossyPat PatOpaqueNegativeLit patternValue + ConPat {pat_con = conValue, pat_args = argsValue} -> + case argsValue of + PrefixCon argValues -> + PConP (unLoc conValue) <$> traverse convertPat argValues + InfixCon leftValue rightValue -> + PConP (unLoc conValue) <$> traverse convertPat [leftValue, rightValue] + RecCon recordFieldsValue -> do + convertedFields <- + traverse (convertRecPatField . unLoc) (rec_flds recordFieldsValue) + case rec_dotdot recordFieldsValue of + Nothing -> + pure (PRecP (unLoc conValue) convertedFields) + Just locatedDotDot -> do + wildcardRegion <- + recordWildcardRegion patternValue locatedDotDot + wildcardBinderNames <- + resolveRecordWildcardBinderNames + wildcardRegion + (unLoc conValue) + (fmap (recordFieldName . unLoc) (rec_flds recordFieldsValue)) + wildcardBinders <- + traverse freshBinderAnn wildcardBinderNames + recordItems <- + insertRecordWildcard + wildcardRegion + (unRecFieldsDotDot (unLoc locatedDotDot)) + wildcardBinders + convertedFields + pure (PRecP (unLoc conValue) recordItems) + OrPat {} -> + lossyPat PatOpaqueOr patternValue + SumPat {} -> + lossyPat PatOpaqueSum patternValue + ViewPat {} -> + lossyPat PatOpaqueView patternValue + SplicePat {} -> + lossyPat PatOpaqueSplice patternValue + NPlusKPat {} -> + lossyPat PatOpaqueNPlusK patternValue + SigPat {} -> + lossyPat PatOpaqueSig patternValue + EmbTyPat {} -> + lossyPat PatOpaqueEmbTy patternValue + InvisPat {} -> + lossyPat PatOpaqueInvis patternValue + +convertRecPatField :: HsRecField GhcPs (LPat GhcPs) -> ConvM HsRecPatItem +convertRecPatField fieldBindValue = + case unLoc (hfbLHS fieldBindValue) of + FieldOcc {foLabel = labelValue} -> do + let fieldName = unLoc labelValue + fieldValue <- + if hfbPun fieldBindValue + then + HsRecPatPun + <$> freshBinderAnn + (mkRdrUnqual (rdrNameOcc fieldName)) + else + HsRecPatExplicit <$> convertPat (hfbRHS fieldBindValue) + pure (HsRecPatField fieldName fieldValue) + +recordFieldName :: HsRecField GhcPs argument -> RdrName +recordFieldName fieldBindValue = + case unLoc (hfbLHS fieldBindValue) of + FieldOcc {foLabel = labelValue} -> + unLoc labelValue + +resolveRecordWildcardBinderNames :: + SourceRegion -> + RdrName -> + [RdrName] -> + ConvM [RdrName] +resolveRecordWildcardBinderNames wildcardRegion constructorName explicitFieldNames = do + constructorFieldNames <- + resolveRecordWildcardFields wildcardRegion constructorName + let explicitOccurrences = + Set.fromList (fmap rdrNameOcc explicitFieldNames) + pure + ( fmap + (mkRdrUnqual . rdrNameOcc) + ( filter + (\fieldName -> Set.notMember (rdrNameOcc fieldName) explicitOccurrences) + constructorFieldNames + ) + ) + +recordWildcardRegion :: + LPat GhcPs -> + GenLocated EpaLocation RecFieldsDotDot -> + ConvM SourceRegion +recordWildcardRegion patternValue locatedDotDot = + case + sourceRegionFromSrcSpan (getHasLoc locatedDotDot) + <|> sourceRegionFromSrcSpan (getLocA patternValue) + of + Just wildcardRegion -> + pure wildcardRegion + Nothing -> + throwConvert + ( ConvertRecordWildcardRegionUnavailable + (sourceRegionFromSrcSpan (getLocA patternValue)) + ) + +insertRecordWildcard :: + SourceRegion -> + Int -> + [BinderAnn] -> + [HsRecPatItem] -> + ConvM [HsRecPatItem] +insertRecordWildcard wildcardRegion wildcardPosition wildcardBinders recordItems + | wildcardPosition < 0 || wildcardPosition > length recordItems = + throwConvert + ( ConvertRecordWildcardPositionInvalid + wildcardRegion + wildcardPosition + (length recordItems) + ) + | otherwise = + let (beforeWildcard, afterWildcard) = + splitAt wildcardPosition recordItems + in pure + ( beforeWildcard + <> [HsRecPatWildcard wildcardRegion wildcardBinders] + <> afterWildcard + ) + +lossyPat :: HsPatOpaqueTag -> LPat GhcPs -> ConvM HsPatF +lossyPat tagValue patternValue = + throwConvert + ( ConvertUnsupportedPattern + (sourceRegionFromSrcSpan (getLocA patternValue)) + tagValue + ) + +convertTupleBoxity :: Boxity -> TupleBoxity +convertTupleBoxity = \case + Boxed -> BoxedTuple + Unboxed -> UnboxedTuple diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Projection.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Projection.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Projection.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Pale.Ghc.Expr.Convert.Projection + ( bindingExpr, + projectBinding, + projectClause, + projectRhs, + attachProjectedBindingGroup, + projectBindingRow, + mkProjectedExpr, + attachBindingGroup + ) +where + +import Control.Monad (foldM) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NonEmpty +import Moonlight.Pale.Ghc.Expr.Convert.Dependencies qualified as Dependencies +import Moonlight.Pale.Ghc.Expr.Convert.FreeScopes (ScopeAlgebra (..)) +import Moonlight.Pale.Ghc.Expr.Convert.FreeScopes qualified as FreeScopes +import Moonlight.Pale.Ghc.Expr.Convert.Row +import Moonlight.Pale.Ghc.Expr.Convert.State +import Moonlight.Pale.Ghc.Expr.Scope +import Moonlight.Pale.Ghc.Expr.Syntax + +bindingExpr :: + ScopeIndex -> + ConvertedValueBinding -> + Either ScopeLookupFailure Expr +bindingExpr scopeIndex topLevelBinding = do + expressionValue <- + projectBinding + scopeIndex + (tlbScope topLevelBinding) + (tlbBinding topLevelBinding) + pure + expressionValue + { exprRegion = tlbRegion topLevelBinding + } + +projectBinding :: + ScopeIndex -> + ScopeId -> + Binding -> + Either ScopeLookupFailure Expr +projectBinding scopeIndex bindingScope = \case + PatternBinding _ rhsValue -> + projectRhs scopeIndex bindingScope rhsValue + FunctionBinding _ clauses -> + case clauses of + Clause patterns rhsValue :| [] + | Just binderAnns <- traverse simplePatternBinderAnn patterns -> do + rhsScope <- + clauseBodyScope scopeIndex bindingScope patterns + rhsExpression <- + projectRhs + scopeIndex + rhsScope + rhsValue + foldM + ( \bodyExpression binderAnn -> do + lambdaScope <- + binderSiteScope scopeIndex (baId binderAnn) + mkProjectedExpr + scopeIndex + lambdaScope + (LamF binderAnn bodyExpression) + ) + rhsExpression + (reverse binderAnns) + clauseValues -> do + projectedClauses <- + traverse + (projectClause scopeIndex bindingScope) + (NonEmpty.toList clauseValues) + mkProjectedExpr + scopeIndex + bindingScope + (ClausesF projectedClauses) + +projectClause :: + ScopeIndex -> + ScopeId -> + Clause -> + Either ScopeLookupFailure ([HsPatF], Expr) +projectClause scopeIndex bindingScope clauseValue = do + rhsScope <- + clauseBodyScope + scopeIndex + bindingScope + (clausePatterns clauseValue) + rhsExpression <- + projectRhs + scopeIndex + rhsScope + (clauseRhs clauseValue) + pure (clausePatterns clauseValue, rhsExpression) + +projectRhs :: + ScopeIndex -> + ScopeId -> + Rhs -> + Either ScopeLookupFailure Expr +projectRhs scopeIndex rhsScope = \case + UnguardedRhs bodyExpression maybeBindingGroup -> + attachProjectedBindingGroup + scopeIndex + rhsScope + maybeBindingGroup + bodyExpression + GuardedRhs guardedAlternatives maybeBindingGroup -> do + guardedExpression <- + mkProjectedExpr + scopeIndex + rhsScope + (GuardedF (NonEmpty.toList guardedAlternatives)) + attachProjectedBindingGroup + scopeIndex + rhsScope + maybeBindingGroup + guardedExpression + +attachProjectedBindingGroup :: + ScopeIndex -> + ScopeId -> + Maybe BindingGroup -> + Expr -> + Either ScopeLookupFailure Expr +attachProjectedBindingGroup _ _ Nothing bodyExpression = + Right bodyExpression +attachProjectedBindingGroup scopeIndex rhsScope (Just bindingGroup) bodyExpression = do + bindingRows <- + traverse + (projectBindingRow scopeIndex (bindingGroupScope bindingGroup)) + (NonEmpty.toList (bindingGroupBindings bindingGroup)) + mkProjectedExpr + scopeIndex + rhsScope + ( LetF + (Dependencies.bindingComponentsRecursion (bindingGroupComponents bindingGroup)) + bindingRows + bodyExpression + ) + +projectBindingRow :: + ScopeIndex -> + ScopeId -> + Binding -> + Either ScopeLookupFailure (HsPatF, Expr) +projectBindingRow scopeIndex bindingScope bindingValue = + (,) + (bindingHeadPattern bindingValue) + <$> projectBinding scopeIndex bindingScope bindingValue + +mkProjectedExpr :: + ScopeIndex -> + ScopeId -> + HsExprF Expr -> + Either ScopeLookupFailure Expr +mkProjectedExpr scopeIndex occurrenceScope expressionNode = do + freeScopes <- + FreeScopes.freeScopesExpr + ScopeAlgebra + { saScopeDepth = scopeDepthOf scopeIndex, + saBinderIntro = binderIntroScope scopeIndex . baId + } + expressionNode + pure + Expr + { exprRegion = Nothing, + exprScope = occurrenceScope, + exprFreeScopes = freeScopes, + exprNode = expressionNode + } + +attachBindingGroup :: + Maybe ConvertedLocalBinds -> + Expr -> + ConvM Expr +attachBindingGroup = \case + Nothing -> + pure + Just convertedBinds -> + mkConvExpr + Nothing + . LetF (clbRecursion convertedBinds) (clbBindings convertedBinds) diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Row.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Row.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Row.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Pale.Ghc.Expr.Convert.Row + ( RecordFieldEnvironment, + emptyRecordFieldEnvironment, + recordFieldEnvironmentFromDefinitions, + resolveRecordFieldEnvironment, + Env, + ConvertedBindingMetrics (..), + ConvertedValueBinding (..), + tlbBinding, + tlbScope, + tlbRegion, + convertedValueBindingMetrics, + Binding (..), + Clause (..), + Rhs (..), + BindingGroup (..), + bindingNames, + bindingPattern, + clausePattern, + rhsPattern, + attachBindingGroupPattern, + bindingRowPattern, + clauseBodyScope, + bindingHeadPattern, + ConvertedModule (..), + ConvertedInstanceDeclaration (..), + InstanceMethodSection (..), + ConvertedBindingOrigin (..), + ConvertedBindingSite (..), + ModuleDeclaration (..), + convertedModuleBindings, + convertedModuleBindingSites, + convertedModuleInstanceMethodObstructions, + convertedModuleTypeSignatures, + convertedModuleFixityDeclarations, + ConvertedLocalBinds (..), + ConvExpr, + ConvertedBinding (..), + convertedBindingRows, + mkBindingGroup, + BindingGroupId (..), + bindingGroupIdKey, + simplePatternBinderAnn, + extendEnv, + convertedExpressionMetrics + ) +where + +import Control.Monad (foldM) +import Data.Kind (Type) +import Data.IntMap.Strict (IntMap) +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 Data.Set (Set) +import Data.Vector (Vector) +import GHC.Types.Name.Reader (RdrName) +import Moonlight.Core (BinderId (..), Pattern (..)) +import Moonlight.Pale.Ghc.Expr.Convert.Dependencies qualified as Dependencies +import Moonlight.Pale.Ghc.Expr.Convert.Obstruction +import Moonlight.Pale.Ghc.Expr.Scope +import Moonlight.Pale.Ghc.Expr.Syntax + +type RecordFieldEnvironment :: Type +newtype RecordFieldEnvironment = RecordFieldEnvironment + { recordFieldDefinitions :: Map RdrName (NonEmpty [RdrName]) + } + deriving stock (Eq, Ord) + +emptyRecordFieldEnvironment :: RecordFieldEnvironment +emptyRecordFieldEnvironment = + RecordFieldEnvironment Map.empty + +recordFieldEnvironmentFromDefinitions :: + [(RdrName, [RdrName])] -> + RecordFieldEnvironment +recordFieldEnvironmentFromDefinitions definitions = + RecordFieldEnvironment + ( Map.fromListWith + (flip (<>)) + ( fmap + (\(constructorName, fieldNames) -> (constructorName, fieldNames :| [])) + definitions + ) + ) + +resolveRecordFieldEnvironment :: + RecordFieldEnvironment -> + RdrName -> + Either RecordWildcardResolutionFailure [RdrName] +resolveRecordFieldEnvironment recordFieldEnvironment constructorName = + case Map.lookup constructorName (recordFieldDefinitions recordFieldEnvironment) of + Nothing -> + Left (RecordWildcardConstructorUnavailable constructorName) + Just (fieldNames :| []) -> + Right fieldNames + Just _ -> + Left (RecordWildcardConstructorAmbiguous constructorName) + +type Env :: Type +type Env = Map RdrName BinderAnn + +type ConvertedBindingMetrics :: Type +data ConvertedBindingMetrics = ConvertedBindingMetrics + { convertedBindingScopedExprCount :: !Int, + convertedBindingGlobalVarRefCount :: !Int, + convertedBindingLocalVarRefCount :: !Int, + convertedBindingMaxFreeScopeCount :: !Int + } + deriving stock (Eq, Ord, Show) + +instance Semigroup ConvertedBindingMetrics where + leftMetrics <> rightMetrics = + ConvertedBindingMetrics + { convertedBindingScopedExprCount = + convertedBindingScopedExprCount leftMetrics + + convertedBindingScopedExprCount rightMetrics, + convertedBindingGlobalVarRefCount = + convertedBindingGlobalVarRefCount leftMetrics + + convertedBindingGlobalVarRefCount rightMetrics, + convertedBindingLocalVarRefCount = + convertedBindingLocalVarRefCount leftMetrics + + convertedBindingLocalVarRefCount rightMetrics, + convertedBindingMaxFreeScopeCount = + max + (convertedBindingMaxFreeScopeCount leftMetrics) + (convertedBindingMaxFreeScopeCount rightMetrics) + } + +instance Monoid ConvertedBindingMetrics where + mempty = + ConvertedBindingMetrics + { convertedBindingScopedExprCount = 0, + convertedBindingGlobalVarRefCount = 0, + convertedBindingLocalVarRefCount = 0, + convertedBindingMaxFreeScopeCount = 0 + } + +type ConvertedValueBinding :: Type +data ConvertedValueBinding = ConvertedValueBinding + { convertedValueBindingValue :: !Binding, + convertedValueBindingScope :: !ScopeId, + convertedValueBindingRegion :: !(Maybe SourceRegion), + convertedValueBindingMetricSection :: !ConvertedBindingMetrics + } + deriving stock (Eq, Ord, Show) + +tlbBinding :: ConvertedValueBinding -> Binding +tlbBinding = + convertedValueBindingValue + +tlbScope :: ConvertedValueBinding -> ScopeId +tlbScope = + convertedValueBindingScope + +tlbRegion :: ConvertedValueBinding -> Maybe SourceRegion +tlbRegion = + convertedValueBindingRegion + +convertedValueBindingMetrics :: ConvertedValueBinding -> ConvertedBindingMetrics +convertedValueBindingMetrics = + convertedValueBindingMetricSection + +type Binding :: Type +data Binding + = FunctionBinding !BinderAnn !(NonEmpty Clause) + | PatternBinding !HsPatF !Rhs + deriving stock (Eq, Ord, Show) + +type Clause :: Type +data Clause = Clause + { clausePatterns :: ![HsPatF], + clauseRhs :: !Rhs + } + deriving stock (Eq, Ord, Show) + +type Rhs :: Type +data Rhs + = UnguardedRhs !Expr !(Maybe BindingGroup) + | GuardedRhs !(NonEmpty (GuardedAltF Expr)) !(Maybe BindingGroup) + deriving stock (Eq, Ord, Show) + +type BindingGroup :: Type +data BindingGroup = BindingGroup + { bindingGroupScope :: !ScopeId, + bindingGroupComponents :: !(NonEmpty BindingComponent), + bindingGroupBindings :: !(NonEmpty Binding) + } + deriving stock (Eq, Ord, Show) + +bindingNames :: Binding -> [RdrName] +bindingNames = \case + FunctionBinding binderAnn _ -> [baName binderAnn] + PatternBinding patternValue _ -> fmap baName (patBinders patternValue) + +bindingPattern :: Binding -> Pattern HsExprF +bindingPattern = \case + PatternBinding _ rhsValue -> + rhsPattern rhsValue + FunctionBinding _ clauses -> + case clauses of + Clause patterns rhsValue :| [] + | Just binderAnns <- traverse simplePatternBinderAnn patterns -> + foldr + (\binderAnn bodyPattern -> PatternNode (LamF binderAnn bodyPattern)) + (rhsPattern rhsValue) + binderAnns + clauseValues -> + PatternNode + ( ClausesF + (fmap clausePattern (NonEmpty.toList clauseValues)) + ) + +clausePattern :: Clause -> ([HsPatF], Pattern HsExprF) +clausePattern clauseValue = + ( clausePatterns clauseValue, + rhsPattern (clauseRhs clauseValue) + ) + +rhsPattern :: Rhs -> Pattern HsExprF +rhsPattern = \case + UnguardedRhs bodyExpression maybeBindingGroup -> + attachBindingGroupPattern maybeBindingGroup (eraseExpr bodyExpression) + GuardedRhs guardedAlternatives maybeBindingGroup -> + attachBindingGroupPattern + maybeBindingGroup + ( PatternNode + (GuardedF (fmap (fmap eraseExpr) (NonEmpty.toList guardedAlternatives))) + ) + +attachBindingGroupPattern :: + Maybe BindingGroup -> + Pattern HsExprF -> + Pattern HsExprF +attachBindingGroupPattern Nothing bodyPattern = + bodyPattern +attachBindingGroupPattern (Just bindingGroup) bodyPattern = + PatternNode + ( LetF + (Dependencies.bindingComponentsRecursion (bindingGroupComponents bindingGroup)) + (fmap bindingRowPattern (NonEmpty.toList (bindingGroupBindings bindingGroup))) + bodyPattern + ) + +bindingRowPattern :: Binding -> (HsPatF, Pattern HsExprF) +bindingRowPattern bindingValue = + (bindingHeadPattern bindingValue, bindingPattern bindingValue) + +clauseBodyScope :: + ScopeIndex -> + ScopeId -> + [HsPatF] -> + Either ScopeLookupFailure ScopeId +clauseBodyScope scopeIndex bindingScope patternValues = + foldM + (\_ binderAnn -> binderIntroScope scopeIndex (baId binderAnn)) + bindingScope + (foldMap patBinders patternValues) + +bindingHeadPattern :: Binding -> HsPatF +bindingHeadPattern = \case + FunctionBinding binderAnn _ -> + PVarP binderAnn + PatternBinding patternValue _ -> + patternValue + +type ConvertedModule :: Type +data ConvertedModule = ConvertedModule + { cmDeclarations :: !(Vector ModuleDeclaration), + cmScopeIndex :: !ScopeIndex, + cmLambdaSites :: ![BinderAnn], + cmLetSites :: ![BinderAnn] + } + +type ConvertedInstanceDeclaration :: Type +data ConvertedInstanceDeclaration = ConvertedInstanceDeclaration + { convertedInstanceRegion :: !SourceRegion, + convertedInstanceSource :: !String, + convertedInstanceMethods :: ![InstanceMethodSection] + } + deriving stock (Eq, Ord, Show) + +type InstanceMethodSection :: Type +data InstanceMethodSection + = TraversableInstanceMethod !ConvertedValueBinding + | ObstructedInstanceMethod !InstanceMethodObstruction + deriving stock (Eq, Ord, Show) + +type ConvertedBindingOrigin :: Type +data ConvertedBindingOrigin + = TopLevelBindingOrigin + | InstanceMethodBindingOrigin !SourceRegion + deriving stock (Eq, Ord, Show) + +type ConvertedBindingSite :: Type +data ConvertedBindingSite = ConvertedBindingSite + { convertedBindingOrigin :: !ConvertedBindingOrigin, + convertedBindingValue :: !ConvertedValueBinding + } + deriving stock (Eq, Ord, Show) + +type ModuleDeclaration :: Type +data ModuleDeclaration + = ValueDeclaration !ConvertedValueBinding + | TypeSignatureDeclaration !TypeSignature + | FixityDeclarationNode !FixityDeclaration + | InstanceDeclarationNode !ConvertedInstanceDeclaration + | OpaqueDeclaration !UnsupportedDeclarationTag !SourceRegion !String + deriving stock (Eq, Ord, Show) + +convertedModuleBindings :: ConvertedModule -> [ConvertedValueBinding] +convertedModuleBindings = + foldMap + ( \case + ValueDeclaration bindingValue -> [bindingValue] + TypeSignatureDeclaration _ -> [] + FixityDeclarationNode _ -> [] + InstanceDeclarationNode _ -> [] + OpaqueDeclaration {} -> [] + ) + . cmDeclarations + +convertedModuleBindingSites :: ConvertedModule -> [ConvertedBindingSite] +convertedModuleBindingSites = + foldMap + ( \case + ValueDeclaration bindingValue -> + [ConvertedBindingSite TopLevelBindingOrigin bindingValue] + TypeSignatureDeclaration _ -> + [] + FixityDeclarationNode _ -> + [] + InstanceDeclarationNode instanceDeclaration -> + foldMap + ( \case + TraversableInstanceMethod bindingValue -> + [ ConvertedBindingSite + (InstanceMethodBindingOrigin (convertedInstanceRegion instanceDeclaration)) + bindingValue + ] + ObstructedInstanceMethod _ -> + [] + ) + (convertedInstanceMethods instanceDeclaration) + OpaqueDeclaration {} -> + [] + ) + . cmDeclarations + +convertedModuleInstanceMethodObstructions :: + ConvertedModule -> + [InstanceMethodObstruction] +convertedModuleInstanceMethodObstructions = + foldMap + ( \case + InstanceDeclarationNode instanceDeclaration -> + foldMap + ( \case + TraversableInstanceMethod _ -> + [] + ObstructedInstanceMethod obstruction -> + [obstruction] + ) + (convertedInstanceMethods instanceDeclaration) + ValueDeclaration _ -> + [] + TypeSignatureDeclaration _ -> + [] + FixityDeclarationNode _ -> + [] + OpaqueDeclaration {} -> + [] + ) + . cmDeclarations + +convertedModuleTypeSignatures :: ConvertedModule -> [TypeSignature] +convertedModuleTypeSignatures = + foldMap + ( \case + TypeSignatureDeclaration signature -> [signature] + ValueDeclaration _ -> [] + FixityDeclarationNode _ -> [] + InstanceDeclarationNode _ -> [] + OpaqueDeclaration {} -> [] + ) + . cmDeclarations + +convertedModuleFixityDeclarations :: ConvertedModule -> [FixityDeclaration] +convertedModuleFixityDeclarations = + foldMap + ( \case + FixityDeclarationNode declaration -> [declaration] + ValueDeclaration _ -> [] + TypeSignatureDeclaration _ -> [] + InstanceDeclarationNode _ -> [] + OpaqueDeclaration {} -> [] + ) + . cmDeclarations + +type ConvertedLocalBinds :: Type +data ConvertedLocalBinds = ConvertedLocalBinds + { clbRecursion :: !LetRecursion, + clbScope :: !ScopeId, + clbGroup :: !BindingGroup, + clbBindings :: ![(HsPatF, ConvExpr)], + clbBinders :: ![BinderAnn], + clbEnv :: !Env + } + +type ConvExpr :: Type +type ConvExpr = Expr + +type ConvertedBinding :: Type +data ConvertedBinding = ConvertedBinding + { cbBinding :: !Binding, + cbExpression :: !Expr + } + +convertedBindingRows :: NonEmpty ConvertedBinding -> NonEmpty (HsPatF, Expr) +convertedBindingRows = + fmap + (\convertedBinding -> (bindingHeadPattern (cbBinding convertedBinding), cbExpression convertedBinding)) + +mkBindingGroup :: + ScopeId -> + NonEmpty ConvertedBinding -> + IntMap (Set BinderId) -> + Either Dependencies.BindingDependencyFailure BindingGroup +mkBindingGroup bindingScope convertedBindings dependenciesByRow = + BindingGroup bindingScope + <$> Dependencies.inferBindingComponents + (fmap (bindingHeadPattern . cbBinding) convertedBindings) + dependenciesByRow + <*> pure (fmap cbBinding convertedBindings) + +type BindingGroupId :: Type +newtype BindingGroupId = BindingGroupId Int + deriving stock (Eq, Ord, Show) + +bindingGroupIdKey :: BindingGroupId -> Int +bindingGroupIdKey (BindingGroupId groupKey) = + groupKey + +simplePatternBinderAnn :: HsPatF -> Maybe BinderAnn +simplePatternBinderAnn = \case + PVarP binderAnn -> Just binderAnn + PParP patternValue -> simplePatternBinderAnn patternValue + PBangP patternValue -> simplePatternBinderAnn patternValue + PLazyP patternValue -> simplePatternBinderAnn patternValue + _ -> Nothing + +extendEnv :: Env -> [BinderAnn] -> Env +extendEnv env binderAnns = + foldr (\binderAnn -> Map.insert (baName binderAnn) binderAnn) env binderAnns + +convertedExpressionMetrics :: Expr -> ConvertedBindingMetrics +convertedExpressionMetrics expressionValue = + let nodeValue = exprNode expressionValue + childMetrics = foldMap convertedExpressionMetrics nodeValue + freeScopeCount = freeScopeSummarySize (exprFreeScopes expressionValue) + (globalRefIncrement, localRefIncrement) = + case nodeValue of + VarF (GlobalName _) -> (1, 0) + VarF (LocalName _) -> (0, 1) + _ -> (0, 0) + in ConvertedBindingMetrics + { convertedBindingScopedExprCount = + convertedBindingScopedExprCount childMetrics + 1, + convertedBindingGlobalVarRefCount = + convertedBindingGlobalVarRefCount childMetrics + globalRefIncrement, + convertedBindingLocalVarRefCount = + convertedBindingLocalVarRefCount childMetrics + localRefIncrement, + convertedBindingMaxFreeScopeCount = + max + (convertedBindingMaxFreeScopeCount childMetrics) + freeScopeCount + } diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Source.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Source.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Source.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Pale.Ghc.Expr.Convert.Source + ( SourceSliceIndex (..), + sourceSliceIndex, + sourceSliceForRegion, + sourcePositionOffset, + sourceColumnOffset, + normalizedTypeText + ) +where + +import Data.Kind (Type) +import Data.Vector.Unboxed qualified as U +import GHC.Utils.Outputable (Outputable, ppr, showSDocUnsafe) +import Moonlight.Pale.Ghc.Expr.Syntax +-- The fields deliberately remain lazy: value-only modules never pay to index +-- source text, while every opaque declaration shares the same forced vectors. +type SourceSliceIndex :: Type +data SourceSliceIndex = SourceSliceIndex + { ssiSourceCharacters :: U.Vector Char, + ssiLineStartOffsets :: U.Vector Int + } + +sourceSliceIndex :: String -> SourceSliceIndex +sourceSliceIndex sourceText = + SourceSliceIndex + { ssiSourceCharacters = sourceCharacters, + ssiLineStartOffsets = + U.cons + 0 + (U.map (+ 1) (U.findIndices (== '\n') sourceCharacters)) + } + where + sourceCharacters = U.fromList sourceText + +sourceSliceForRegion :: SourceSliceIndex -> SourceRegion -> Maybe (SourceRegion, String) +sourceSliceForRegion moduleSourceIndex regionValue = do + startOffset <- + sourcePositionOffset + moduleSourceIndex + (srStartLine regionValue) + (srStartCol regionValue) + endOffset <- + sourcePositionOffset + moduleSourceIndex + (srEndLine regionValue) + (srEndCol regionValue) + if startOffset <= endOffset + then + Just + ( regionValue, + U.toList + ( U.take + (endOffset - startOffset) + (U.drop startOffset (ssiSourceCharacters moduleSourceIndex)) + ) + ) + else Nothing + +sourcePositionOffset :: SourceSliceIndex -> Int -> Int -> Maybe Int +sourcePositionOffset moduleSourceIndex targetLine targetColumn + | targetLine < 1 = + Nothing + | otherwise = do + lineStartOffset <- + ssiLineStartOffsets moduleSourceIndex U.!? (targetLine - 1) + sourceColumnOffset + (ssiSourceCharacters moduleSourceIndex) + lineStartOffset + targetColumn + +sourceColumnOffset :: U.Vector Char -> Int -> Int -> Maybe Int +sourceColumnOffset sourceCharacters lineStartOffset targetColumn + | targetColumn < 1 || lineStartOffset < 0 = + Nothing + | otherwise = + go 1 lineStartOffset + where + go !currentColumn !currentOffset + | currentColumn == targetColumn = + Just currentOffset + | currentColumn > targetColumn = + Nothing + | otherwise = + case sourceCharacters U.!? currentOffset of + Nothing -> + Nothing + Just sourceCharacter + | sourceCharacter == '\n' -> + Nothing + | sourceCharacter == '\t' -> + go + (currentColumn + 8 - ((currentColumn - 1) `mod` 8)) + (currentOffset + 1) + | otherwise -> + go + (currentColumn + 1) + (currentOffset + 1) + +normalizedTypeText :: Outputable a => a -> NormalizedTypeText +normalizedTypeText = + NormalizedTypeText . unwords . words . showSDocUnsafe . ppr diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/State.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/State.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/State.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Pale.Ghc.Expr.Convert.State + ( BinderOwner (..), + GroupMachinery (..), + emptyGroupMachinery, + ConvState (..), + ConvM, + throwConvert, + liftConvertEither, + runInstanceMethodSection, + initialConvState, + initialConvStateWithRecordFieldEnvironment, + resolveRecordWildcardFields, + resolveVarRef, + currentScopeId, + withScope, + freshChildScope, + scopeDepthInState, + mkConvExpr, + throwUnsupportedExpression, + freshBinderAnn, + recordLambdaSite, + recordLetSite, + currentScopeAlgebra, + modifyGroupMachinery, + freshBindingGroupId, + registerBindingOwners, + withActiveBindingRow, + recordBindingDependency, + takeBindingDependencies + ) +where + +import Control.Monad.State.Strict (StateT (..), gets, modify', runStateT, state) +import Control.Monad.Trans.Class (lift) +import Data.Kind (Type) +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Types.Name.Reader (RdrName) +import Moonlight.Core (BinderId (..), binderIdKey) +import Moonlight.Pale.Ghc.Expr.Convert.FreeScopes (ScopeAlgebra (..)) +import Moonlight.Pale.Ghc.Expr.Convert.FreeScopes qualified as FreeScopes +import Moonlight.Pale.Ghc.Expr.Convert.Obstruction +import Moonlight.Pale.Ghc.Expr.Convert.Row +import Moonlight.Pale.Ghc.Expr.Opaque +import Moonlight.Pale.Ghc.Expr.Scope +import Moonlight.Pale.Ghc.Expr.Syntax + +type BinderOwner :: Type +newtype BinderOwner = BinderOwner + { binderOwnerGroup :: BindingGroupId + } + deriving stock (Eq, Ord, Show) + +type GroupMachinery :: Type +data GroupMachinery = GroupMachinery + { gmNextGroupId :: !Int, + gmBinderOwners :: !(IntMap BinderOwner), + gmActiveRows :: !(IntMap Int), + gmDependencies :: !(IntMap (IntMap (Set BinderId))) + } + +emptyGroupMachinery :: GroupMachinery +emptyGroupMachinery = + GroupMachinery 0 IntMap.empty IntMap.empty IntMap.empty + +type ConvState :: Type +data ConvState = ConvState + { csRecordFieldEnvironment :: !RecordFieldEnvironment, + csNextBinderId :: !Int, + csNextScopeId :: !Int, + csCurrentScope :: !ScopeId, + csScopeParentsRev :: ![Int], + csScopeDepths :: !(IntMap Int), + csBinderIntroRev :: ![Int], + csBinderIntroMap :: !(IntMap ScopeId), + csGroupMachinery :: !GroupMachinery, + csLambdaSites :: ![BinderAnn], + csLetSites :: ![BinderAnn] + } + +type ConvM :: Type -> Type +type ConvM = StateT ConvState (Either ConvertObstruction) + +throwConvert :: ConvertObstruction -> ConvM value +throwConvert = + lift . Left + +liftConvertEither :: Either ConvertObstruction value -> ConvM value +liftConvertEither = + either throwConvert pure + +runInstanceMethodSection :: + Maybe SourceRegion -> + ConvM value -> + ConvM (Either InstanceMethodObstruction value) +runInstanceMethodSection methodRegion action = + StateT + ( \checkpointState -> + case runStateT action checkpointState of + Right (value, methodState) -> + Right (Right value, methodState) + Left obstruction -> + case recoverableInstanceMethodObstruction methodRegion obstruction of + Just methodObstruction -> + Right (Left methodObstruction, checkpointState) + Nothing -> + Left obstruction + ) + +initialConvState :: ConvState +initialConvState = + initialConvStateWithRecordFieldEnvironment emptyRecordFieldEnvironment + +initialConvStateWithRecordFieldEnvironment :: + RecordFieldEnvironment -> + ConvState +initialConvStateWithRecordFieldEnvironment recordFieldEnvironment = + ConvState + { csRecordFieldEnvironment = recordFieldEnvironment, + csNextBinderId = 0, + csNextScopeId = 1, + csCurrentScope = rootScopeId, + csScopeParentsRev = [0], + csScopeDepths = IntMap.singleton 0 0, + csBinderIntroRev = [], + csBinderIntroMap = IntMap.empty, + csGroupMachinery = emptyGroupMachinery, + csLambdaSites = [], + csLetSites = [] + } + +resolveRecordWildcardFields :: + SourceRegion -> + RdrName -> + ConvM [RdrName] +resolveRecordWildcardFields wildcardRegion constructorName = do + recordFieldEnvironment <- gets csRecordFieldEnvironment + either + (throwConvert . ConvertRecordWildcardResolutionUnavailable wildcardRegion) + pure + (resolveRecordFieldEnvironment recordFieldEnvironment constructorName) + +resolveVarRef :: Env -> RdrName -> ConvM HsVarRef +resolveVarRef env nameValue = + case Map.lookup nameValue env of + Nothing -> + pure (GlobalName nameValue) + Just binderAnn -> do + recordBindingDependency binderAnn + pure (LocalName binderAnn) + +currentScopeId :: ConvM ScopeId +currentScopeId = + gets csCurrentScope + +withScope :: ScopeId -> ConvM value -> ConvM value +withScope scopeId action = do + previousScope <- gets csCurrentScope + modify' (\stateValue -> stateValue {csCurrentScope = scopeId}) + resultValue <- action + modify' (\stateValue -> stateValue {csCurrentScope = previousScope}) + pure resultValue + +freshChildScope :: ConvM ScopeId +freshChildScope = do + parentScope <- gets csCurrentScope + parentDepth <- scopeDepthInState parentScope + nextScopeId <- gets csNextScopeId + childScope <- + either + (throwConvert . ConvertFreshScopeIdFailure nextScopeId) + pure + (mkScopeId nextScopeId) + let !parentKey = scopeIdKey parentScope + modify' + ( \stateValue -> + stateValue + { csNextScopeId = nextScopeId + 1, + csScopeParentsRev = parentKey : csScopeParentsRev stateValue, + csScopeDepths = IntMap.insert nextScopeId (parentDepth + 1) (csScopeDepths stateValue) + } + ) + pure childScope + +scopeDepthInState :: ScopeId -> ConvM Int +scopeDepthInState scopeId = do + depthMap <- gets csScopeDepths + maybe + (throwConvert (ConvertMissingScopeDepth scopeId)) + pure + (IntMap.lookup (scopeIdKey scopeId) depthMap) + +mkConvExpr :: Maybe SourceRegion -> HsExprF Expr -> ConvM Expr +mkConvExpr region nodeValue = do + occurrenceScope <- currentScopeId + scopeAlgebra <- currentScopeAlgebra + freeScopes <- liftConvertEither (FreeScopes.freeScopesExpr scopeAlgebra nodeValue) + pure + Expr + { exprRegion = region, + exprScope = occurrenceScope, + exprFreeScopes = freeScopes, + exprNode = nodeValue + } + +throwUnsupportedExpression :: Maybe SourceRegion -> HsOpaqueTag -> ConvM value +throwUnsupportedExpression region opaqueTag = + throwConvert (ConvertUnsupportedExpression region opaqueTag) + +freshBinderAnn :: RdrName -> ConvM BinderAnn +freshBinderAnn binderName = do + nextBinderId <- gets csNextBinderId + introScope <- gets csCurrentScope + let !introKey = scopeIdKey introScope + modify' + ( \stateValue -> + stateValue + { csNextBinderId = nextBinderId + 1, + csBinderIntroRev = introKey : csBinderIntroRev stateValue, + csBinderIntroMap = IntMap.insert nextBinderId introScope (csBinderIntroMap stateValue) + } + ) + pure + BinderAnn + { baId = BinderId nextBinderId, + baName = binderName + } + +recordLambdaSite :: BinderAnn -> ConvM () +recordLambdaSite binderAnn = + modify' (\stateValue -> stateValue {csLambdaSites = binderAnn : csLambdaSites stateValue}) + +recordLetSite :: BinderAnn -> ConvM () +recordLetSite binderAnn = + modify' (\stateValue -> stateValue {csLetSites = binderAnn : csLetSites stateValue}) + +currentScopeAlgebra :: ConvM (ScopeAlgebra ConvertObstruction) +currentScopeAlgebra = do + depthMap <- gets csScopeDepths + introMap <- gets csBinderIntroMap + pure + ScopeAlgebra + { saScopeDepth = + \scopeId -> + maybe + (Left (ConvertMissingScopeSummaryDepth scopeId)) + Right + (IntMap.lookup (scopeIdKey scopeId) depthMap), + saBinderIntro = + \binderAnn -> + maybe + (Left (ConvertMissingBinderIntro (baId binderAnn))) + Right + (IntMap.lookup (binderIdKey (baId binderAnn)) introMap) + } + +modifyGroupMachinery :: (GroupMachinery -> GroupMachinery) -> ConvM () +modifyGroupMachinery adjustMachinery = + modify' + ( \stateValue -> + stateValue {csGroupMachinery = adjustMachinery (csGroupMachinery stateValue)} + ) + +freshBindingGroupId :: ConvM BindingGroupId +freshBindingGroupId = do + nextGroupId <- gets (gmNextGroupId . csGroupMachinery) + modifyGroupMachinery + (\machineryValue -> machineryValue {gmNextGroupId = nextGroupId + 1}) + pure (BindingGroupId nextGroupId) + +registerBindingOwners :: BindingGroupId -> NonEmpty HsPatF -> ConvM () +registerBindingOwners bindingGroupId bindingPatterns = + modifyGroupMachinery + ( \machineryValue -> + machineryValue + { gmBinderOwners = + foldr + (uncurry IntMap.insert) + (gmBinderOwners machineryValue) + [ ( binderIdKey (baId binderAnn), + BinderOwner bindingGroupId + ) + | bindingPatternValue <- NonEmpty.toList bindingPatterns, + binderAnn <- patBinders bindingPatternValue + ] + } + ) + +withActiveBindingRow :: BindingGroupId -> Int -> ConvM value -> ConvM value +withActiveBindingRow bindingGroupId rowIndex action = do + let groupKey = bindingGroupIdKey bindingGroupId + previousRow <- gets (IntMap.lookup groupKey . gmActiveRows . csGroupMachinery) + modifyGroupMachinery + ( \machineryValue -> + machineryValue + { gmActiveRows = + IntMap.insert groupKey rowIndex (gmActiveRows machineryValue) + } + ) + resultValue <- action + modifyGroupMachinery + ( \machineryValue -> + machineryValue + { gmActiveRows = + maybe + (IntMap.delete groupKey (gmActiveRows machineryValue)) + (\previousRowIndex -> IntMap.insert groupKey previousRowIndex (gmActiveRows machineryValue)) + previousRow + } + ) + pure resultValue + +recordBindingDependency :: BinderAnn -> ConvM () +recordBindingDependency binderAnn = do + maybeOwner <- + gets + (IntMap.lookup (binderIdKey (baId binderAnn)) . gmBinderOwners . csGroupMachinery) + case maybeOwner of + Nothing -> + pure () + Just binderOwner -> do + let groupKey = bindingGroupIdKey (binderOwnerGroup binderOwner) + maybeSourceRow <- + gets (IntMap.lookup groupKey . gmActiveRows . csGroupMachinery) + case maybeSourceRow of + Nothing -> + pure () + Just sourceRow -> + modifyGroupMachinery + ( \machineryValue -> + machineryValue + { gmDependencies = + IntMap.insertWith + (IntMap.unionWith Set.union) + groupKey + (IntMap.singleton sourceRow (Set.singleton (baId binderAnn))) + (gmDependencies machineryValue) + } + ) + +takeBindingDependencies :: + BindingGroupId -> + [BinderAnn] -> + ConvM (IntMap (Set BinderId)) +takeBindingDependencies bindingGroupId bindingAnnotations = do + let groupKey = bindingGroupIdKey bindingGroupId + state + ( \stateValue -> + let machineryValue = csGroupMachinery stateValue + in ( IntMap.findWithDefault + IntMap.empty + groupKey + (gmDependencies machineryValue), + stateValue + { csGroupMachinery = + machineryValue + { gmBinderOwners = + foldr + ( \binderAnn binderOwners -> + IntMap.delete + (binderIdKey (baId binderAnn)) + binderOwners + ) + (gmBinderOwners machineryValue) + bindingAnnotations, + gmDependencies = + IntMap.delete groupKey (gmDependencies machineryValue) + } + } + ) + ) diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Equivalence.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Equivalence.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Equivalence.hs @@ -0,0 +1,466 @@ +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Pale.Ghc.Expr.Equivalence + ( renderRoundTripEquivalent, + renderRoundTripGuardStatementsEquivalent, + ) +where + +import Control.Monad (foldM) +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.List.NonEmpty qualified as NonEmpty +import Moonlight.Core (Pattern (..), binderIdKey) +import Moonlight.Pale.Ghc.Expr.NameRender (renderRdrName) +import Moonlight.Pale.Ghc.Expr.Syntax + +data AlphaEnv = AlphaEnv + { aeLeftLevels :: !(IntMap Int), + aeRightLevels :: !(IntMap Int), + aeNextLevel :: !Int + } + +emptyAlphaEnv :: AlphaEnv +emptyAlphaEnv = + AlphaEnv IntMap.empty IntMap.empty 0 + +renderRoundTripEquivalent :: Pattern HsExprF -> Pattern HsExprF -> Bool +renderRoundTripEquivalent = + equivalentExpr emptyAlphaEnv + +renderRoundTripGuardStatementsEquivalent :: + [HsGuardStmtF (Pattern HsExprF)] -> + [HsGuardStmtF (Pattern HsExprF)] -> + Bool +renderRoundTripGuardStatementsEquivalent leftGuards rightGuards = + maybe + False + (const True) + (equivalentGuards emptyAlphaEnv leftGuards rightGuards) + +equivalentExpr :: AlphaEnv -> Pattern HsExprF -> Pattern HsExprF -> Bool +equivalentExpr alphaEnv leftValue rightValue = + case (stripParens leftValue, stripParens rightValue) of + (PatternVar leftVar, PatternVar rightVar) -> + leftVar == rightVar + (PatternNode leftNode, PatternNode rightNode) -> + equivalentNode alphaEnv leftNode rightNode + _ -> + False + +stripParens :: Pattern HsExprF -> Pattern HsExprF +stripParens = \case + PatternNode (ParF innerValue) -> stripParens innerValue + patternValue -> patternValue + +equivalentNode :: AlphaEnv -> HsExprF (Pattern HsExprF) -> HsExprF (Pattern HsExprF) -> Bool +equivalentNode alphaEnv leftNode rightNode = + case (leftNode, rightNode) of + (VarF leftRef, VarF rightRef) -> + equivalentVarRef alphaEnv leftRef rightRef + (AppF leftFunction leftArgument, AppF rightFunction rightArgument) -> + equivalentExpr alphaEnv leftFunction rightFunction + && equivalentExpr alphaEnv leftArgument rightArgument + (LamF leftBinder leftBody, LamF rightBinder rightBody) -> + maybe False (\bodyEnv -> equivalentExpr bodyEnv leftBody rightBody) (bindPair alphaEnv leftBinder rightBinder) + (LetF leftMode leftBindings leftBody, LetF rightMode rightBindings rightBody) -> + leftMode == rightMode + && maybe + False + ( \(bindingEnv, rhsPairs) -> + all + (\(leftRhs, rightRhs) -> equivalentExpr bindingEnv leftRhs rightRhs) + rhsPairs + && equivalentExpr bindingEnv leftBody rightBody + ) + (equivalentBindingGroup alphaEnv leftBindings rightBindings) + (OpChainF leftFirst leftTail, OpChainF rightFirst rightTail) -> + equivalentExpr alphaEnv leftFirst rightFirst + && equivalentOpChainTail alphaEnv (NonEmpty.toList leftTail) (NonEmpty.toList rightTail) + (SectionLF leftExpr leftOperator, SectionLF rightExpr rightOperator) -> + equivalentExpr alphaEnv leftExpr rightExpr + && equivalentExpr alphaEnv leftOperator rightOperator + (SectionRF leftOperator leftExpr, SectionRF rightOperator rightExpr) -> + equivalentExpr alphaEnv leftOperator rightOperator + && equivalentExpr alphaEnv leftExpr rightExpr + (LitF leftLiteral, LitF rightLiteral) -> + equivalentLit leftLiteral rightLiteral + (OverLitF leftLiteral, OverLitF rightLiteral) -> + leftLiteral == rightLiteral + (IfF leftCondition leftThen leftElse, IfF rightCondition rightThen rightElse) -> + all + id + [ equivalentExpr alphaEnv leftCondition rightCondition, + equivalentExpr alphaEnv leftThen rightThen, + equivalentExpr alphaEnv leftElse rightElse + ] + (CaseF leftScrutinee leftAlternatives, CaseF rightScrutinee rightAlternatives) -> + equivalentExpr alphaEnv leftScrutinee rightScrutinee + && equivalentAlternativeList alphaEnv leftAlternatives rightAlternatives + (DoF leftStatements, DoF rightStatements) -> + maybe False (const True) (equivalentStatements alphaEnv leftStatements rightStatements) + (NegF leftExpr, NegF rightExpr) -> + equivalentExpr alphaEnv leftExpr rightExpr + (ExplicitListF leftExprs, ExplicitListF rightExprs) -> + equivalentExprList alphaEnv leftExprs rightExprs + (ExplicitTupleF leftBoxity leftSlots, ExplicitTupleF rightBoxity rightSlots) -> + leftBoxity == rightBoxity + && equivalentTupleSlots alphaEnv leftSlots rightSlots + (RecordConF leftConstructor leftFields, RecordConF rightConstructor rightFields) -> + equivalentExpr alphaEnv leftConstructor rightConstructor + && equivalentFields alphaEnv leftFields rightFields + (RecordUpdF leftRecord leftFields, RecordUpdF rightRecord rightFields) -> + equivalentExpr alphaEnv leftRecord rightRecord + && equivalentFields alphaEnv leftFields rightFields + (ArithSeqF leftSeq, ArithSeqF rightSeq) -> + equivalentArithSeq alphaEnv leftSeq rightSeq + (GuardedF leftAlts, GuardedF rightAlts) -> + equivalentGuardedAlts alphaEnv leftAlts rightAlts + (ClausesF leftClauses, ClausesF rightClauses) -> + equivalentClauses alphaEnv leftClauses rightClauses + (MultiIfF leftAlts, MultiIfF rightAlts) -> + equivalentGuardedAlts alphaEnv leftAlts rightAlts + (ExprWithTySigF leftExpr leftType, ExprWithTySigF rightExpr rightType) -> + equivalentExpr alphaEnv leftExpr rightExpr && leftType == rightType + (AppTypeF leftExpr leftType, AppTypeF rightExpr rightType) -> + equivalentExpr alphaEnv leftExpr rightExpr && leftType == rightType + _ -> + False + +equivalentVarRef :: AlphaEnv -> HsVarRef -> HsVarRef -> Bool +equivalentVarRef alphaEnv leftRef rightRef = + case (leftRef, rightRef) of + (GlobalName leftName, GlobalName rightName) -> + renderRdrName leftName == renderRdrName rightName + (LocalName leftBinder, LocalName rightBinder) -> + case + ( IntMap.lookup (binderIdKey (baId leftBinder)) (aeLeftLevels alphaEnv), + IntMap.lookup (binderIdKey (baId rightBinder)) (aeRightLevels alphaEnv) + ) + of + (Just leftLevel, Just rightLevel) -> + leftLevel == rightLevel + (Nothing, Nothing) -> + baId leftBinder == baId rightBinder + _ -> + False + _ -> + False + +bindPair :: AlphaEnv -> BinderAnn -> BinderAnn -> Maybe AlphaEnv +bindPair alphaEnv leftBinder rightBinder = + let leftKey = binderIdKey (baId leftBinder) + rightKey = binderIdKey (baId rightBinder) + in case + ( IntMap.lookup leftKey (aeLeftLevels alphaEnv), + IntMap.lookup rightKey (aeRightLevels alphaEnv) + ) + of + (Nothing, Nothing) -> + let nextLevel = aeNextLevel alphaEnv + in Just + alphaEnv + { aeLeftLevels = IntMap.insert leftKey nextLevel (aeLeftLevels alphaEnv), + aeRightLevels = IntMap.insert rightKey nextLevel (aeRightLevels alphaEnv), + aeNextLevel = nextLevel + 1 + } + (Just leftLevel, Just rightLevel) + | leftLevel == rightLevel -> + Just alphaEnv + _ -> + Nothing + +equivalentPattern :: AlphaEnv -> HsPatF -> HsPatF -> Maybe AlphaEnv +equivalentPattern alphaEnv leftPattern rightPattern = + case (stripPatParens leftPattern, stripPatParens rightPattern) of + (PVarP leftBinder, PVarP rightBinder) -> + bindPair alphaEnv leftBinder rightBinder + (PWildP, PWildP) -> + Just alphaEnv + (PConP leftName leftSubs, PConP rightName rightSubs) + | renderRdrName leftName == renderRdrName rightName -> + equivalentPatternList alphaEnv leftSubs rightSubs + (PTupleP leftBoxity leftSubs, PTupleP rightBoxity rightSubs) + | leftBoxity == rightBoxity -> + equivalentPatternList alphaEnv leftSubs rightSubs + (PListP leftSubs, PListP rightSubs) -> + equivalentPatternList alphaEnv leftSubs rightSubs + (PLitP leftLit, PLitP rightLit) + | equivalentLit leftLit rightLit -> + Just alphaEnv + (POverLitP leftLit, POverLitP rightLit) + | leftLit == rightLit -> + Just alphaEnv + (PAsP leftBinder leftSub, PAsP rightBinder rightSub) -> + bindPair alphaEnv leftBinder rightBinder + >>= \boundEnv -> equivalentPattern boundEnv leftSub rightSub + (PBangP leftSub, PBangP rightSub) -> + equivalentPattern alphaEnv leftSub rightSub + (PLazyP leftSub, PLazyP rightSub) -> + equivalentPattern alphaEnv leftSub rightSub + (PRecP leftName leftFields, PRecP rightName rightFields) + | renderRdrName leftName == renderRdrName rightName -> + equivalentPatternFields alphaEnv leftFields rightFields + _ -> + Nothing + +stripPatParens :: HsPatF -> HsPatF +stripPatParens = \case + PParP innerPattern -> stripPatParens innerPattern + patternValue -> patternValue + +equivalentPatternList :: AlphaEnv -> [HsPatF] -> [HsPatF] -> Maybe AlphaEnv +equivalentPatternList alphaEnv leftPatterns rightPatterns = + zipExact leftPatterns rightPatterns + >>= foldM + (\currentEnv (leftPattern, rightPattern) -> equivalentPattern currentEnv leftPattern rightPattern) + alphaEnv + +equivalentPatternFields :: + AlphaEnv -> + [HsRecPatItem] -> + [HsRecPatItem] -> + Maybe AlphaEnv +equivalentPatternFields alphaEnv leftItems rightItems = + zipExact leftItems rightItems + >>= foldM compareItem alphaEnv + where + compareItem :: + AlphaEnv -> + (HsRecPatItem, HsRecPatItem) -> + Maybe AlphaEnv + compareItem currentEnv = \case + ( HsRecPatField leftName (HsRecPatExplicit leftPattern), + HsRecPatField rightName (HsRecPatExplicit rightPattern) + ) + | renderRdrName leftName == renderRdrName rightName -> + equivalentPattern currentEnv leftPattern rightPattern + ( HsRecPatField leftName (HsRecPatPun leftBinder), + HsRecPatField rightName (HsRecPatPun rightBinder) + ) + | renderRdrName leftName == renderRdrName rightName -> + bindPair currentEnv leftBinder rightBinder + ( HsRecPatWildcard _ leftBinders, + HsRecPatWildcard _ rightBinders + ) -> + zipExact leftBinders rightBinders + >>= foldM + (\binderEnv (leftBinder, rightBinder) -> bindPair binderEnv leftBinder rightBinder) + currentEnv + _ -> + Nothing + +equivalentBindingGroup :: + AlphaEnv -> + [(HsPatF, Pattern HsExprF)] -> + [(HsPatF, Pattern HsExprF)] -> + Maybe (AlphaEnv, [(Pattern HsExprF, Pattern HsExprF)]) +equivalentBindingGroup alphaEnv leftBindings rightBindings = do + bindingPairs <- zipExact leftBindings rightBindings + bindingEnv <- + foldM + ( \currentEnv ((leftPattern, _), (rightPattern, _)) -> + equivalentPattern currentEnv leftPattern rightPattern + ) + alphaEnv + bindingPairs + pure + ( bindingEnv, + fmap + (\((_, leftRhs), (_, rightRhs)) -> (leftRhs, rightRhs)) + bindingPairs + ) + +equivalentAlternativeList :: + AlphaEnv -> + [(HsPatF, Pattern HsExprF)] -> + [(HsPatF, Pattern HsExprF)] -> + Bool +equivalentAlternativeList alphaEnv leftAlternatives rightAlternatives = + maybe + False + (all equivalentAlternative) + (zipExact leftAlternatives rightAlternatives) + where + equivalentAlternative ((leftPattern, leftRhs), (rightPattern, rightRhs)) = + maybe + False + (\rhsEnv -> equivalentExpr rhsEnv leftRhs rightRhs) + (equivalentPattern alphaEnv leftPattern rightPattern) + +equivalentStatements :: + AlphaEnv -> + [HsStmtF (Pattern HsExprF)] -> + [HsStmtF (Pattern HsExprF)] -> + Maybe AlphaEnv +equivalentStatements alphaEnv leftStatements rightStatements = + zipExact leftStatements rightStatements >>= foldM equivalentStatement alphaEnv + +equivalentStatement :: + AlphaEnv -> + (HsStmtF (Pattern HsExprF), HsStmtF (Pattern HsExprF)) -> + Maybe AlphaEnv +equivalentStatement alphaEnv = \case + (BindStmtF leftPattern leftExpr, BindStmtF rightPattern rightExpr) + | equivalentExpr alphaEnv leftExpr rightExpr -> + equivalentPattern alphaEnv leftPattern rightPattern + (BodyStmtF leftExpr, BodyStmtF rightExpr) + | equivalentExpr alphaEnv leftExpr rightExpr -> + Just alphaEnv + (LetStmtF leftMode leftBindings, LetStmtF rightMode rightBindings) + | leftMode == rightMode -> + equivalentBindingGroup alphaEnv leftBindings rightBindings + >>= \(bindingEnv, rhsPairs) -> + if all (uncurry (equivalentExpr bindingEnv)) rhsPairs + then Just bindingEnv + else Nothing + _ -> + Nothing + +equivalentGuardedAlts :: + AlphaEnv -> + [GuardedAltF (Pattern HsExprF)] -> + [GuardedAltF (Pattern HsExprF)] -> + Bool +equivalentGuardedAlts alphaEnv leftAlts rightAlts = + maybe False (all equivalentAlt) (zipExact leftAlts rightAlts) + where + equivalentAlt (leftAlt, rightAlt) = + maybe + False + (\bodyEnv -> equivalentExpr bodyEnv (gaBody leftAlt) (gaBody rightAlt)) + (equivalentGuards alphaEnv (gaGuards leftAlt) (gaGuards rightAlt)) + +equivalentGuards :: + AlphaEnv -> + [HsGuardStmtF (Pattern HsExprF)] -> + [HsGuardStmtF (Pattern HsExprF)] -> + Maybe AlphaEnv +equivalentGuards alphaEnv leftGuards rightGuards = + zipExact leftGuards rightGuards >>= foldM equivalentGuard alphaEnv + +equivalentGuard :: + AlphaEnv -> + (HsGuardStmtF (Pattern HsExprF), HsGuardStmtF (Pattern HsExprF)) -> + Maybe AlphaEnv +equivalentGuard alphaEnv = \case + (GuardBoolF leftExpr, GuardBoolF rightExpr) + | equivalentExpr alphaEnv leftExpr rightExpr -> + Just alphaEnv + (GuardPatF leftPattern leftExpr, GuardPatF rightPattern rightExpr) + | equivalentExpr alphaEnv leftExpr rightExpr -> + equivalentPattern alphaEnv leftPattern rightPattern + (GuardLetF leftMode leftBindings, GuardLetF rightMode rightBindings) + | leftMode == rightMode -> + equivalentBindingGroup alphaEnv leftBindings rightBindings + >>= \(bindingEnv, rhsPairs) -> + if all (uncurry (equivalentExpr bindingEnv)) rhsPairs + then Just bindingEnv + else Nothing + _ -> + Nothing + +equivalentClauses :: + AlphaEnv -> + [([HsPatF], Pattern HsExprF)] -> + [([HsPatF], Pattern HsExprF)] -> + Bool +equivalentClauses alphaEnv leftClauses rightClauses = + maybe False (all equivalentClause) (zipExact leftClauses rightClauses) + where + equivalentClause ((leftPatterns, leftBody), (rightPatterns, rightBody)) = + maybe + False + (\bodyEnv -> equivalentExpr bodyEnv leftBody rightBody) + (equivalentPatternList alphaEnv leftPatterns rightPatterns) + +equivalentExprList :: + AlphaEnv -> + [Pattern HsExprF] -> + [Pattern HsExprF] -> + Bool +equivalentExprList alphaEnv leftExprs rightExprs = + maybe + False + (all (uncurry (equivalentExpr alphaEnv))) + (zipExact leftExprs rightExprs) + +equivalentOpChainTail :: + AlphaEnv -> + [(Pattern HsExprF, Pattern HsExprF)] -> + [(Pattern HsExprF, Pattern HsExprF)] -> + Bool +equivalentOpChainTail alphaEnv leftTail rightTail = + maybe False (all equivalentPair) (zipExact leftTail rightTail) + where + equivalentPair ((leftOperator, leftOperand), (rightOperator, rightOperand)) = + equivalentExpr alphaEnv leftOperator rightOperator + && equivalentExpr alphaEnv leftOperand rightOperand + +equivalentTupleSlots :: + AlphaEnv -> + [TupleSlot (Pattern HsExprF)] -> + [TupleSlot (Pattern HsExprF)] -> + Bool +equivalentTupleSlots alphaEnv leftSlots rightSlots = + maybe False (all equivalentSlot) (zipExact leftSlots rightSlots) + where + equivalentSlot = \case + (TupleMissing, TupleMissing) -> True + (TuplePresent leftExpr, TuplePresent rightExpr) -> + equivalentExpr alphaEnv leftExpr rightExpr + _ -> False + +equivalentFields :: + AlphaEnv -> + [(NormalizedFieldLabel, Pattern HsExprF)] -> + [(NormalizedFieldLabel, Pattern HsExprF)] -> + Bool +equivalentFields alphaEnv leftFields rightFields = + maybe False (all equivalentField) (zipExact leftFields rightFields) + where + equivalentField ((leftLabel, leftExpr), (rightLabel, rightExpr)) = + leftLabel == rightLabel && equivalentExpr alphaEnv leftExpr rightExpr + +equivalentArithSeq :: + AlphaEnv -> + NormalizedArithSeq (Pattern HsExprF) -> + NormalizedArithSeq (Pattern HsExprF) -> + Bool +equivalentArithSeq alphaEnv leftSeq rightSeq = + case (leftSeq, rightSeq) of + (ArithSeqFrom leftFrom, ArithSeqFrom rightFrom) -> + equivalentExpr alphaEnv leftFrom rightFrom + (ArithSeqFromThen leftFrom leftThen, ArithSeqFromThen rightFrom rightThen) -> + equivalentExpr alphaEnv leftFrom rightFrom + && equivalentExpr alphaEnv leftThen rightThen + (ArithSeqFromTo leftFrom leftTo, ArithSeqFromTo rightFrom rightTo) -> + equivalentExpr alphaEnv leftFrom rightFrom + && equivalentExpr alphaEnv leftTo rightTo + (ArithSeqFromThenTo leftFrom leftThen leftTo, ArithSeqFromThenTo rightFrom rightThen rightTo) -> + all + id + [ equivalentExpr alphaEnv leftFrom rightFrom, + equivalentExpr alphaEnv leftThen rightThen, + equivalentExpr alphaEnv leftTo rightTo + ] + _ -> + False + +equivalentLit :: NormalizedLit -> NormalizedLit -> Bool +equivalentLit leftLiteral rightLiteral = + normalizeMultiline leftLiteral == normalizeMultiline rightLiteral + where + normalizeMultiline = \case + NormalizedMultilineString value -> NormalizedString value + literalValue -> literalValue + +zipExact :: [left] -> [right] -> Maybe [(left, right)] +zipExact leftValues rightValues = + case (leftValues, rightValues) of + ([], []) -> + Just [] + (leftValue : remainingLeft, rightValue : remainingRight) -> + ((leftValue, rightValue) :) <$> zipExact remainingLeft remainingRight + _ -> + Nothing diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/NameRender.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/NameRender.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/NameRender.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Pale.Ghc.Expr.NameRender + ( renderRdrName, + varRefRdrName, + ) +where + +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Name.Reader (RdrName, isQual_maybe, rdrNameOcc) +import Language.Haskell.Syntax.Module.Name (moduleNameString) +import Moonlight.Pale.Ghc.Expr.Syntax + +varRefRdrName :: HsVarRef -> RdrName +varRefRdrName = \case + GlobalName rdrName -> rdrName + LocalName binderAnn -> baName binderAnn + +renderRdrName :: RdrName -> String +renderRdrName nameValue = + case isQual_maybe nameValue of + Just (moduleName, occName) -> + moduleNameString moduleName <> "." <> occNameString occName + Nothing -> + occNameString (rdrNameOcc nameValue) diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Opaque.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Opaque.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Opaque.hs @@ -0,0 +1,61 @@ +module Moonlight.Pale.Ghc.Expr.Opaque + ( HsOpaqueTag (..), + HsPatOpaqueTag (..), + hsOpaqueTagName, + hsPatOpaqueTagName, + ) +where + +import Data.Kind (Type) + +type HsOpaqueTag :: Type +data HsOpaqueTag + = OpaqueOverLabel + | OpaqueIPVar + | OpaqueExplicitSum + | OpaqueOverloadedRecordUpdate + | OpaqueGetField + | OpaqueProjection + | OpaqueTypedBracket + | OpaqueUntypedBracket + | OpaqueTypedSplice + | OpaqueUntypedSplice + | OpaqueProc + | OpaqueStatic + | OpaquePragE + | OpaqueEmbTy + | OpaqueHole + | OpaqueForAll + | OpaqueQual + | OpaqueFunArr + | OpaqueCaseAlternative + | OpaqueEmptyLocalBinds + | OpaqueImplicitParameterBinds + | OpaquePatternSynonymBind + | OpaqueExtensionValBinds + | OpaqueParallelStatement + | OpaqueTransformStatement + | OpaqueRecursiveStatement + deriving stock (Eq, Ord, Show, Enum, Bounded) + +type HsPatOpaqueTag :: Type +data HsPatOpaqueTag + = PatOpaqueOr + | PatOpaqueSum + | PatOpaqueView + | PatOpaqueSplice + | PatOpaqueNPlusK + | PatOpaqueSig + | PatOpaqueEmbTy + | PatOpaqueInvis + | PatOpaqueNegativeLit + | PatOpaqueExtension + deriving stock (Eq, Ord, Show, Enum, Bounded) + +hsOpaqueTagName :: HsOpaqueTag -> String +hsOpaqueTagName = + show + +hsPatOpaqueTagName :: HsPatOpaqueTag -> String +hsPatOpaqueTagName = + show diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Parse.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Parse.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Parse.hs @@ -0,0 +1,30 @@ +{-| Parsing Haskell source into the scoped expression algebra. -} +module Moonlight.Pale.Ghc.Expr.Parse + ( parseHsExprSource, + convertHaskellExprSource, + ) +where + +import GHC.Hs (GhcPs, HsExpr, LHsExpr) +import GHC.Parser (parseExpression) +import GHC.Parser.Lexer (P) +import GHC.Parser.PostProcess (PV, runPV, unECP) +import GHC.Types.SrcLoc (unLoc) +import Moonlight.Core (Pattern) +import Moonlight.Pale.Ghc.Expr.Convert.Coalgebra (convertHsExpr) +import Moonlight.Pale.Ghc.Expr.Convert.Obstruction (ConvertObstruction (..)) +import Moonlight.Pale.Ghc.Expr.Syntax (HsExprF) +import Moonlight.Pale.Ghc.ModuleSurface (GhcParseFailure, parseWithGhcParser) + +parseHsExprSource :: String -> Either GhcParseFailure (HsExpr GhcPs) +parseHsExprSource sourceText = + unLoc <$> parseWithGhcParser "" sourceText parseLocatedHsExpr + +convertHaskellExprSource :: String -> Either ConvertObstruction (Pattern HsExprF) +convertHaskellExprSource sourceText = + either (Left . ConvertParseFailure) convertHsExpr (parseHsExprSource sourceText) + +parseLocatedHsExpr :: P (LHsExpr GhcPs) +parseLocatedHsExpr = do + exprValue <- parseExpression + runPV (unECP exprValue :: PV (LHsExpr GhcPs)) diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moonlight.Pale.Ghc.Expr.Render + ( LayoutPolicy (..), + PageWidth, + defaultPageWidth, + mkPageWidth, + ModuleRenderContext (..), + RenderTarget (..), + RenderRefusal (..), + renderSource, + renderRoundTripEquivalent, + ) +where + +import Data.Text qualified as Text +import Moonlight.Pale.Ghc.Expr.Equivalence (renderRoundTripEquivalent) +import Moonlight.Pale.Ghc.Expr.Render.Document +import Moonlight.Pale.Ghc.Expr.Render.Module +import Moonlight.Pale.Ghc.Expr.Render.Refusal + +renderSource :: LayoutPolicy -> RenderTarget -> Either RenderRefusal Text.Text +renderSource = \case + CompactLayout -> + fmap renderCompactDocument + . renderSourceWith CompactRender + PrettyLayout pageWidth -> + fmap (renderPrettyDocument pageWidth) + . renderSourceWith GeneratedRender diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Analysis.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Analysis.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Analysis.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moonlight.Pale.Ghc.Expr.Render.Analysis + ( RequiredExtension (..), + requiredLanguageHeader, + requiredConvertedLanguageHeader, + bindingRequiredExtensions, + rhsRequiredExtensions, + exprRequiredExtensions, + patternRequiredExtensions, + validateClauses, + isLambdaBinderPattern, + isGuardedBody + ) +where + +import Data.Kind (Type) +import Data.Set (Set) +import Data.Set qualified as Set +import Moonlight.Core (Pattern (..)) +import Moonlight.Pale.Ghc.Expr.Convert.Coalgebra + ( Binding (..), + bindingGroupBindings, + Clause (..), + Rhs (..), + ConvertedValueBinding, + tlbBinding, + ) +import Moonlight.Pale.Ghc.Expr.Render.Carrier +import Moonlight.Pale.Ghc.Expr.Render.Refusal +import Moonlight.Pale.Ghc.Expr.Syntax + +type RequiredExtension :: Type +data RequiredExtension + = MultiWayIfExtension + | NamedFieldPunsExtension + | RecordWildCardsExtension + deriving stock (Eq, Ord, Show, Enum, Bounded) + +type RequiredExtensions :: Type +newtype RequiredExtensions = RequiredExtensions + { requiredExtensionSet :: Set RequiredExtension + } + +instance Semigroup RequiredExtensions where + RequiredExtensions leftExtensions <> RequiredExtensions rightExtensions = + RequiredExtensions (Set.union leftExtensions rightExtensions) + +instance Monoid RequiredExtensions where + mempty = + RequiredExtensions Set.empty + +requiredLanguageHeader :: [Pattern HsExprF] -> String +requiredLanguageHeader expressionValues = + renderRequiredLanguageHeader + (foldMap patternRequiredExtensions expressionValues) + +requiredConvertedLanguageHeader :: [ConvertedValueBinding] -> String +requiredConvertedLanguageHeader bindings = + renderRequiredLanguageHeader + (foldMap (bindingRequiredExtensions . tlbBinding) bindings) + +renderRequiredLanguageHeader :: RequiredExtensions -> String +renderRequiredLanguageHeader = + foldMap + ( \requiredExtension -> + "{-# LANGUAGE " + <> requiredExtensionName requiredExtension + <> " #-}\n" + ) + . Set.toAscList + . requiredExtensionSet + +requiredExtensionName :: RequiredExtension -> String +requiredExtensionName = \case + MultiWayIfExtension -> + "MultiWayIf" + NamedFieldPunsExtension -> + "NamedFieldPuns" + RecordWildCardsExtension -> + "RecordWildCards" + +singletonRequiredExtension :: RequiredExtension -> RequiredExtensions +singletonRequiredExtension = + RequiredExtensions . Set.singleton + +bindingRequiredExtensions :: Binding -> RequiredExtensions +bindingRequiredExtensions = \case + FunctionBinding _ clauses -> + foldMap + ( \clauseValue -> + foldMap hsPatRequiredExtensions (clausePatterns clauseValue) + <> rhsRequiredExtensions (clauseRhs clauseValue) + ) + clauses + PatternBinding patternValue rhsValue -> + hsPatRequiredExtensions patternValue + <> rhsRequiredExtensions rhsValue + +rhsRequiredExtensions :: Rhs -> RequiredExtensions +rhsRequiredExtensions = \case + UnguardedRhs bodyExpression maybeBindingGroup -> + exprRequiredExtensions bodyExpression + <> maybe + mempty + (foldMap bindingRequiredExtensions . bindingGroupBindings) + maybeBindingGroup + GuardedRhs alternatives maybeBindingGroup -> + foldMap (guardedAltRequiredExtensions exprRequiredExtensions) alternatives + <> maybe + mempty + (foldMap bindingRequiredExtensions . bindingGroupBindings) + maybeBindingGroup + +exprRequiredExtensions :: Expr -> RequiredExtensions +exprRequiredExtensions expressionValue = + expressionNodeRequiredExtensions + exprRequiredExtensions + (exprNode expressionValue) + +patternRequiredExtensions :: Pattern HsExprF -> RequiredExtensions +patternRequiredExtensions = \case + PatternVar _ -> + mempty + PatternNode nodeValue -> + expressionNodeRequiredExtensions + patternRequiredExtensions + nodeValue + +expressionNodeRequiredExtensions :: + (recursive -> RequiredExtensions) -> + HsExprF recursive -> + RequiredExtensions +expressionNodeRequiredExtensions recursiveRequiredExtensions nodeValue = + constructorRequiredExtensions + <> expressionNodePatternRequiredExtensions nodeValue + <> foldMap recursiveRequiredExtensions nodeValue + where + constructorRequiredExtensions = + case nodeValue of + MultiIfF {} -> + singletonRequiredExtension MultiWayIfExtension + _ -> + mempty + +expressionNodePatternRequiredExtensions :: + HsExprF recursive -> + RequiredExtensions +expressionNodePatternRequiredExtensions = \case + LetF _ bindingValues _ -> + foldMap (hsPatRequiredExtensions . fst) bindingValues + CaseF _ alternatives -> + foldMap (hsPatRequiredExtensions . fst) alternatives + DoF statements -> + foldMap statementPatternRequiredExtensions statements + GuardedF alternatives -> + foldMap guardedAltPatternRequiredExtensions alternatives + ClausesF clauses -> + foldMap + (foldMap hsPatRequiredExtensions . fst) + clauses + MultiIfF alternatives -> + foldMap guardedAltPatternRequiredExtensions alternatives + _ -> + mempty + +guardedAltRequiredExtensions :: + (recursive -> RequiredExtensions) -> + GuardedAltF recursive -> + RequiredExtensions +guardedAltRequiredExtensions recursiveRequiredExtensions guardedAlternative = + guardedAltPatternRequiredExtensions guardedAlternative + <> foldMap recursiveRequiredExtensions guardedAlternative + +guardedAltPatternRequiredExtensions :: + GuardedAltF recursive -> + RequiredExtensions +guardedAltPatternRequiredExtensions = + foldMap guardPatternRequiredExtensions . gaGuards + +guardPatternRequiredExtensions :: + HsGuardStmtF recursive -> + RequiredExtensions +guardPatternRequiredExtensions = \case + GuardBoolF _ -> + mempty + GuardPatF patternValue _ -> + hsPatRequiredExtensions patternValue + GuardLetF _ bindingValues -> + foldMap (hsPatRequiredExtensions . fst) bindingValues + +statementPatternRequiredExtensions :: + HsStmtF recursive -> + RequiredExtensions +statementPatternRequiredExtensions = \case + BindStmtF patternValue _ -> + hsPatRequiredExtensions patternValue + BodyStmtF _ -> + mempty + LetStmtF _ bindingValues -> + foldMap (hsPatRequiredExtensions . fst) bindingValues + +hsPatRequiredExtensions :: HsPatF -> RequiredExtensions +hsPatRequiredExtensions = \case + PVarP _ -> + mempty + PWildP -> + mempty + PConP _ subPatterns -> + foldMap hsPatRequiredExtensions subPatterns + PTupleP _ subPatterns -> + foldMap hsPatRequiredExtensions subPatterns + PListP subPatterns -> + foldMap hsPatRequiredExtensions subPatterns + PLitP _ -> + mempty + POverLitP _ -> + mempty + PAsP _ subPattern -> + hsPatRequiredExtensions subPattern + PBangP subPattern -> + hsPatRequiredExtensions subPattern + PLazyP subPattern -> + hsPatRequiredExtensions subPattern + PParP subPattern -> + hsPatRequiredExtensions subPattern + PRecP _ recordItems -> + foldMap recordItemRequiredExtensions recordItems + +recordItemRequiredExtensions :: + HsRecPatItem -> + RequiredExtensions +recordItemRequiredExtensions = \case + HsRecPatField _ (HsRecPatExplicit fieldPattern) -> + hsPatRequiredExtensions fieldPattern + HsRecPatField _ (HsRecPatPun _) -> + singletonRequiredExtension NamedFieldPunsExtension + HsRecPatWildcard _ _ -> + singletonRequiredExtension RecordWildCardsExtension + +validateClauses :: [([HsPatF], recursive)] -> Either RenderRefusal [([HsPatF], recursive)] +validateClauses clauseValues = + case clauseValues of + [] -> + Left RenderClausesShape + [(patternValues, _)] + | null patternValues || all isLambdaBinderPattern patternValues -> + Left RenderClausesShape + (firstPatterns, _) : _ -> + let arityValue = length firstPatterns + in if arityValue == 0 || any ((/= arityValue) . length . fst) clauseValues + then Left RenderClausesShape + else Right clauseValues + +isLambdaBinderPattern :: HsPatF -> Bool +isLambdaBinderPattern = \case + PVarP {} -> + True + PParP innerPattern -> + isLambdaBinderPattern innerPattern + PBangP innerPattern -> + isLambdaBinderPattern innerPattern + PLazyP innerPattern -> + isLambdaBinderPattern innerPattern + _ -> + False + +isGuardedBody :: RenderSource recursive -> recursive -> Either RenderRefusal Bool +isGuardedBody renderContext bodyValue = do + nodeValue <- rsProjectNode renderContext bodyValue + Right + ( case nodeValue of + GuardedF {} -> + True + _ -> + False + ) diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Annotation.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Annotation.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Annotation.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moonlight.Pale.Ghc.Expr.Render.Annotation + ( bindingRootExpressions, + rhsRootExpressions, + bindingGroupRootExpressions, + bindingRenderAnnotations, + localBindingRenderAnnotations, + bindingHeadAnnotations, + clauseRenderAnnotations, + rhsRenderAnnotations, + bindingGroupRenderAnnotations, + nodeBindingAnnotations, + statementBindingAnnotations, + guardedAltBindingAnnotations, + guardBindingAnnotations + ) +where + +import Data.Foldable qualified as Foldable +import Moonlight.Pale.Ghc.Expr.Convert.Coalgebra + ( Binding (..), + BindingGroup, + bindingGroupBindings, + Clause (..), + Rhs (..), + ) +import Moonlight.Pale.Ghc.Expr.Syntax +bindingRootExpressions :: Binding -> [Expr] +bindingRootExpressions = \case + FunctionBinding _ clauses -> + foldMap (rhsRootExpressions . clauseRhs) clauses + PatternBinding _ rhsValue -> + rhsRootExpressions rhsValue + +rhsRootExpressions :: Rhs -> [Expr] +rhsRootExpressions = \case + UnguardedRhs bodyExpression maybeBindingGroup -> + bodyExpression : foldMap bindingGroupRootExpressions maybeBindingGroup + GuardedRhs guardedAlternatives maybeBindingGroup -> + foldMap Foldable.toList guardedAlternatives + <> foldMap bindingGroupRootExpressions maybeBindingGroup + +bindingGroupRootExpressions :: BindingGroup -> [Expr] +bindingGroupRootExpressions = + foldMap bindingRootExpressions . bindingGroupBindings + +bindingRenderAnnotations :: Binding -> [BinderAnn] +bindingRenderAnnotations = \case + FunctionBinding _ clauses -> + foldMap clauseRenderAnnotations clauses + PatternBinding _ rhsValue -> + rhsRenderAnnotations rhsValue + +localBindingRenderAnnotations :: Binding -> [BinderAnn] +localBindingRenderAnnotations bindingValue = + bindingHeadAnnotations bindingValue <> bindingRenderAnnotations bindingValue + +bindingHeadAnnotations :: Binding -> [BinderAnn] +bindingHeadAnnotations = \case + FunctionBinding binderAnn _ -> + [binderAnn] + PatternBinding patternValue _ -> + patBinders patternValue + +clauseRenderAnnotations :: Clause -> [BinderAnn] +clauseRenderAnnotations clauseValue = + foldMap patBinders (clausePatterns clauseValue) + <> rhsRenderAnnotations (clauseRhs clauseValue) + +rhsRenderAnnotations :: Rhs -> [BinderAnn] +rhsRenderAnnotations = \case + UnguardedRhs _ maybeBindingGroup -> + foldMap bindingGroupRenderAnnotations maybeBindingGroup + GuardedRhs guardedAlternatives maybeBindingGroup -> + foldMap guardedAltBindingAnnotations guardedAlternatives + <> foldMap bindingGroupRenderAnnotations maybeBindingGroup + +bindingGroupRenderAnnotations :: BindingGroup -> [BinderAnn] +bindingGroupRenderAnnotations = + foldMap localBindingRenderAnnotations . bindingGroupBindings + +nodeBindingAnnotations :: HsExprF recursive -> [BinderAnn] +nodeBindingAnnotations = \case + LamF binderAnn _ -> + [binderAnn] + LetF _ bindingValues _ -> + foldMap (patBinders . fst) bindingValues + CaseF _ alternatives -> + foldMap (patBinders . fst) alternatives + DoF statementValues -> + foldMap statementBindingAnnotations statementValues + GuardedF guardedAlts -> + foldMap guardedAltBindingAnnotations guardedAlts + ClausesF clauseValues -> + foldMap (foldMap patBinders . fst) clauseValues + MultiIfF guardedAlts -> + foldMap guardedAltBindingAnnotations guardedAlts + _ -> + [] + +statementBindingAnnotations :: HsStmtF recursive -> [BinderAnn] +statementBindingAnnotations = \case + BindStmtF patternValue _ -> + patBinders patternValue + LetStmtF _ bindingValues -> + foldMap (patBinders . fst) bindingValues + BodyStmtF _ -> + [] + +guardedAltBindingAnnotations :: GuardedAltF recursive -> [BinderAnn] +guardedAltBindingAnnotations = + foldMap guardBindingAnnotations . gaGuards + +guardBindingAnnotations :: HsGuardStmtF recursive -> [BinderAnn] +guardBindingAnnotations = \case + GuardPatF patternValue _ -> + patBinders patternValue + GuardLetF _ bindingValues -> + foldMap (patBinders . fst) bindingValues + GuardBoolF _ -> + [] diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Binding.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Binding.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Binding.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moonlight.Pale.Ghc.Expr.Render.Binding + ( renderBindingWith, + renderBindingWithSource, + renderTopLevelBindingWith, + renderBindingLhs, + renderBindingClause, + renderBindingRhs, + appendWhereGroup, + renderWhereGroup, + renderInlineWhereGroup, + renderGuardedTopLevelAlts, + renderGuardedTopLevelAlt + ) +where + +import Data.List.NonEmpty qualified as NonEmpty +import Moonlight.Pale.Ghc.Expr.Convert.Coalgebra + ( Binding (..), + BindingGroup, + bindingGroupBindings, + Clause (..), + Rhs (..), + ) +import Moonlight.Pale.Ghc.Expr.Render.Carrier +import Moonlight.Pale.Ghc.Expr.Render.Document +import Moonlight.Pale.Ghc.Expr.Render.Expression +import Moonlight.Pale.Ghc.Expr.Render.Name +import Moonlight.Pale.Ghc.Expr.Render.Pattern +import Moonlight.Pale.Ghc.Expr.Render.Refusal +import Moonlight.Pale.Ghc.Expr.Syntax + +renderBindingWith :: + RenderDocument document => + RenderMode -> + Binding -> + Either RenderRefusal document +renderBindingWith renderMode bindingValue = do + renderContext <- bindingRenderSource bindingValue + renderBindingWithSource renderContext renderMode bindingValue + +renderBindingWithSource :: + RenderDocument document => + RenderSource Expr -> + RenderMode -> + Binding -> + Either RenderRefusal document +renderBindingWithSource renderContext renderMode = \case + FunctionBinding binderAnn clauses -> + vcat + <$> traverse + (renderBindingClause renderContext renderMode (renderDefinitionName (renderBinderSpelling renderContext binderAnn))) + (NonEmpty.toList clauses) + PatternBinding patternValue rhsValue -> do + patternDoc <- renderPat renderContext False patternValue + renderBindingRhs renderContext renderMode patternDoc rhsValue + +renderTopLevelBindingWith :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + String -> + recursive -> + Either RenderRefusal document +renderTopLevelBindingWith renderContext renderMode bindingName bindingTerm + | null bindingName = + Left RenderEmptyBindingName + | otherwise = do + bodyDoc <- renderExprWith renderContext renderMode 0 bindingTerm + Right + ( renderDelimitedExpression + renderMode + (renderDefinitionName bindingName) + "=" + bodyDoc + ) + +renderBindingLhs :: + RenderDocument document => + RenderSource recursive -> + document -> + [HsPatF] -> + Either RenderRefusal document +renderBindingLhs renderContext headDoc patternValues = + case patternValues of + [] -> + Right headDoc + _ -> + renderClauseLhs renderContext headDoc patternValues + +renderBindingClause :: + RenderDocument document => + RenderSource Expr -> + RenderMode -> + document -> + Clause -> + Either RenderRefusal document +renderBindingClause renderContext renderMode bindingHead clauseValue = do + lhsDoc <- + renderBindingLhs renderContext bindingHead (clausePatterns clauseValue) + renderBindingRhs renderContext renderMode lhsDoc (clauseRhs clauseValue) + +renderBindingRhs :: + RenderDocument document => + RenderSource Expr -> + RenderMode -> + document -> + Rhs -> + Either RenderRefusal document +renderBindingRhs renderContext renderMode lhsDoc = \case + UnguardedRhs bodyExpression maybeWhereGroup -> do + bodyDoc <- + renderExprWith + renderContext + renderMode + 0 + bodyExpression + appendWhereGroup + renderContext + renderMode + maybeWhereGroup + (renderDelimitedExpression renderMode lhsDoc "=" bodyDoc) + GuardedRhs guardedAlternatives maybeWhereGroup -> do + equationDoc <- + renderGuardedTopLevelAlts + renderContext + renderMode + lhsDoc + (NonEmpty.toList guardedAlternatives) + appendWhereGroup renderContext renderMode maybeWhereGroup equationDoc + +appendWhereGroup :: + RenderDocument document => + RenderSource Expr -> + RenderMode -> + Maybe BindingGroup -> + document -> + Either RenderRefusal document +appendWhereGroup renderContext renderMode maybeBindingGroup equationDoc = + case maybeBindingGroup of + Nothing -> + Right equationDoc + Just bindingGroup -> do + case renderMode of + CompactRender -> do + whereSuffix <- + renderInlineWhereGroup renderContext CompactRender bindingGroup + Right (equationDoc <> whereSuffix) + GeneratedRender -> do + whereDoc <- + renderWhereGroup renderContext GeneratedRender bindingGroup + Right (vcat [equationDoc, whereDoc]) + +renderWhereGroup :: + RenderDocument document => + RenderSource Expr -> + RenderMode -> + BindingGroup -> + Either RenderRefusal document +renderWhereGroup renderContext renderMode bindingGroup = do + bindingDocs <- + traverse + (renderBindingWithSource renderContext renderMode) + (NonEmpty.toList (bindingGroupBindings bindingGroup)) + Right (vcat [nest 2 (text "where"), nest 4 (vcat bindingDocs)]) + +renderInlineWhereGroup :: + RenderDocument document => + RenderSource Expr -> + RenderMode -> + BindingGroup -> + Either RenderRefusal document +renderInlineWhereGroup renderContext renderMode bindingGroup = do + bindingDocs <- + traverse + (renderBindingWithSource renderContext renderMode) + (NonEmpty.toList (bindingGroupBindings bindingGroup)) + Right (renderBlock renderMode " where" bindingDocs) + +renderGuardedTopLevelAlts :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + document -> + [GuardedAltF recursive] -> + Either RenderRefusal document +renderGuardedTopLevelAlts renderContext renderMode lhsDoc guardedAlts = + case guardedAlts of + [] -> + Left RenderGuardedExpression + [GuardedAltF [] bodyValue] -> do + bodyDoc <- renderExprWith renderContext renderMode 0 bodyValue + Right (lhsDoc <> text " = " <> bodyDoc) + _ -> do + altDocs <- traverse (renderGuardedTopLevelAlt renderContext renderMode) guardedAlts + Right + ( case renderMode of + CompactRender -> + lhsDoc <+> intercalateDoc (text " ") altDocs + GeneratedRender -> + vcat (lhsDoc : fmap (nest 2) altDocs) + ) + +renderGuardedTopLevelAlt :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + GuardedAltF recursive -> + Either RenderRefusal document +renderGuardedTopLevelAlt renderContext renderMode = + renderGuardedAlt renderContext renderMode (text "| ") " = " diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Carrier.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Carrier.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Carrier.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moonlight.Pale.Ghc.Expr.Render.Carrier + ( LocalBindingRows, + RenderNodeProjection, + RenderSource (..), + projectPatternNode + ) +where + +import Data.Kind (Type) +import Data.IntMap.Strict (IntMap) +import GHC.Types.Name.Reader (RdrName) +import Moonlight.Core (Pattern (..)) +import Moonlight.Pale.Ghc.Expr.Render.Refusal +import Moonlight.Pale.Ghc.Expr.Syntax + +type LocalBindingRows :: Type -> Type +type LocalBindingRows recursive = [(HsPatF, recursive)] + +type RenderNodeProjection recursive = recursive -> Either RenderRefusal (HsExprF recursive) + +type RenderSource :: Type -> Type +data RenderSource recursive = RenderSource + { rsProjectNode :: !(RenderNodeProjection recursive), + rsRenderNames :: !(IntMap RdrName) + } + +projectPatternNode :: RenderNodeProjection (Pattern HsExprF) +projectPatternNode = \case + PatternVar _ -> + Left RenderPatternVariable + PatternNode nodeValue -> + Right nodeValue diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Document.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Document.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Document.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moonlight.Pale.Ghc.Expr.Render.Document + ( PageWidth (..), + defaultPageWidth, + mkPageWidth, + LayoutPolicy (..), + RenderMode (..), + RenderDocument (..), + CompactDocument (..), + PrettyDocument (..), + intercalateDocument, + (<+>), + nest, + renderCompactDocument, + renderPrettyDocument, + renderDelimitedExpression, + renderBlock, + wrapParen, + hcat, + intercalateDoc + ) +where + +import Data.Kind (Constraint, Type) +import Data.Text qualified as Text +import Data.Text.Lazy qualified as LazyText +import Data.Text.Lazy.Builder qualified as TextBuilder +import Prettyprinter qualified as Pretty +import Prettyprinter.Render.Text qualified as PrettyText +type PageWidth :: Type +newtype PageWidth = PageWidth Int + deriving stock (Eq, Ord, Show) + +defaultPageWidth :: PageWidth +defaultPageWidth = + PageWidth 80 + +mkPageWidth :: Int -> Maybe PageWidth +mkPageWidth columnCount + | columnCount > 0 = + Just (PageWidth columnCount) + | otherwise = + Nothing + +type LayoutPolicy :: Type +data LayoutPolicy + = CompactLayout + | PrettyLayout !PageWidth + deriving stock (Eq, Ord, Show) + +type RenderMode :: Type +data RenderMode + = CompactRender + | GeneratedRender + +type RenderDocument :: Type -> Constraint +class Monoid document => RenderDocument document where + text :: String -> document + hangingIndent :: Int -> document -> document + vcat :: [document] -> document + hsep :: [document] -> document + group :: document -> document + line :: document + parenthesizeDoc :: document -> document + +newtype CompactDocument = CompactDocument + { compactDocumentBuilder :: TextBuilder.Builder + } + deriving newtype (Semigroup, Monoid) + +instance RenderDocument CompactDocument where + text = + CompactDocument . TextBuilder.fromString + hangingIndent _ documentValue = + documentValue + vcat = + intercalateDocument (text "\n") + hsep = + intercalateDocument (text " ") + group = + id + line = + text "\n" + parenthesizeDoc documentValue = + text "(" <> documentValue <> text ")" + +newtype PrettyDocument = PrettyDocument + { prettyDocumentValue :: Pretty.Doc () + } + deriving newtype (Semigroup, Monoid) + +instance RenderDocument PrettyDocument where + text = + PrettyDocument . Pretty.pretty + hangingIndent indentationAmount (PrettyDocument documentValue) = + PrettyDocument (Pretty.nest indentationAmount documentValue) + vcat documentValues = + PrettyDocument + ( Pretty.concatWith + (\leftDocument rightDocument -> leftDocument <> Pretty.hardline <> rightDocument) + (fmap prettyDocumentValue documentValues) + ) + hsep = + PrettyDocument . Pretty.hsep . fmap prettyDocumentValue + group = + PrettyDocument . Pretty.group . prettyDocumentValue + line = + PrettyDocument Pretty.line + parenthesizeDoc = + PrettyDocument . Pretty.parens . prettyDocumentValue + +intercalateDocument :: + Monoid document => + document -> + [document] -> + document +intercalateDocument separatorDocument documentValues = + case documentValues of + [] -> + mempty + firstDocument : remainingDocuments -> + firstDocument + <> foldMap (separatorDocument <>) remainingDocuments + +(<+>) :: + RenderDocument document => + document -> + document -> + document +leftDocument <+> rightDocument = + leftDocument <> text " " <> rightDocument + +-- Indent a block, first line included; 'hangingIndent' alone moves only the +-- continuation lines and so must not be substituted here. +nest :: + RenderDocument document => + Int -> + document -> + document +nest indentationAmount documentValue = + text (replicate indentationAmount ' ') + <> hangingIndent indentationAmount documentValue + +renderCompactDocument :: CompactDocument -> Text.Text +renderCompactDocument = + LazyText.toStrict + . TextBuilder.toLazyText + . compactDocumentBuilder + +renderPrettyDocument :: PageWidth -> PrettyDocument -> Text.Text +renderPrettyDocument (PageWidth columnCount) = + PrettyText.renderStrict + . Pretty.layoutPretty + (Pretty.LayoutOptions (Pretty.AvailablePerLine columnCount 1.0)) + . prettyDocumentValue + +renderDelimitedExpression :: + RenderDocument document => + RenderMode -> + document -> + String -> + document -> + document +renderDelimitedExpression renderMode lhsDoc delimiter bodyDoc = + case renderMode of + CompactRender -> + lhsDoc <+> text delimiter <+> bodyDoc + GeneratedRender -> + group + ( lhsDoc + <+> text delimiter + <> hangingIndent 2 (line <> bodyDoc) + ) + +-- Shared brace-and-semicolon (compact) / indented (generated) block layout for a +-- keyword followed by a list of item docs (@let@, @where@, @\\case@, @\\cases@, @do@). +renderBlock :: + RenderDocument document => + RenderMode -> + String -> + [document] -> + document +renderBlock renderMode keyword itemDocs = + case renderMode of + CompactRender -> + text (keyword <> " { ") <> intercalateDoc (text "; ") itemDocs <> text " }" + GeneratedRender -> + vcat [text keyword, nest 2 (vcat itemDocs)] + +wrapParen :: + RenderDocument document => + Bool -> + document -> + document +wrapParen shouldWrap innerDoc = + if shouldWrap then parenthesizeDoc innerDoc else innerDoc + +hcat :: + Monoid document => + [document] -> + document +hcat = + mconcat + +intercalateDoc :: + Monoid document => + document -> + [document] -> + document +intercalateDoc separatorDoc docValues = + intercalateDocument separatorDoc docValues diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Expression.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Expression.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Expression.hs @@ -0,0 +1,561 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moonlight.Pale.Ghc.Expr.Render.Expression + ( renderExprWith, + renderClausesExpression, + renderPatternLambda, + renderLambdaCase, + renderLambdaCaseAlt, + renderLambdaCases, + renderLambdaCasesAlt, + renderClauseLhs, + renderClauseArrow, + renderClauseArrowCore, + renderGuardedAlt, + renderOpChain, + renderCaseBranch, + renderCaseExpression, + renderGuardedCaseAlts, + renderGuardedCaseAlt, + renderMultiIf, + renderMultiIfAlt, + renderDoExpression, + renderDoStatement, + renderLetStatement, + renderLetExpression, + renderLetBinding, + renderGuardStatements, + renderGuardStatement, + renderRecordLike, + renderField, + renderRecordExpression, + renderArithSeq + ) +where + +import Data.List.NonEmpty qualified as NonEmpty +import Moonlight.Pale.Ghc.Expr.Render.Analysis +import Moonlight.Pale.Ghc.Expr.Render.Carrier +import Moonlight.Pale.Ghc.Expr.Render.Document +import Moonlight.Pale.Ghc.Expr.Render.Literal +import Moonlight.Pale.Ghc.Expr.Render.Name +import Moonlight.Pale.Ghc.Expr.Render.Pattern +import Moonlight.Pale.Ghc.Expr.Render.Refusal +import Moonlight.Pale.Ghc.Expr.Syntax + +renderExprWith :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + Int -> + recursive -> + Either RenderRefusal document +renderExprWith renderContext renderMode parentPrecedence expressionTerm = do + expressionValue <- rsProjectNode renderContext expressionTerm + case expressionValue of + VarF variableReference -> + Right (renderVarRefAtom renderContext variableReference) + AppF functionValue argumentValue -> do + functionDoc <- renderExprWith renderContext renderMode 10 functionValue + argumentDoc <- renderExprWith renderContext renderMode 11 argumentValue + Right (wrapParen (parentPrecedence > 10) (functionDoc <> text " " <> argumentDoc)) + LamF binderAnn bodyValue -> do + bodyDoc <- renderExprWith renderContext renderMode 0 bodyValue + Right (wrapParen (parentPrecedence > 0) (text "\\" <> renderBinderAnn renderContext binderAnn <> text " -> " <> bodyDoc)) + LetF _ bindingValues bodyValue -> + renderLetExpression renderContext renderMode parentPrecedence bindingValues bodyValue + OpChainF firstOperand chainTail -> + renderOpChain renderContext renderMode parentPrecedence firstOperand (NonEmpty.toList chainTail) + SectionLF leftValue operatorValue -> do + leftDoc <- renderExprWith renderContext renderMode 0 leftValue + operatorDoc <- renderOperator renderContext operatorValue + Right (text "(" <> leftDoc <> text " " <> operatorDoc <> text ")") + SectionRF operatorValue rightValue -> do + operatorDoc <- renderOperator renderContext operatorValue + rightDoc <- renderExprWith renderContext renderMode 0 rightValue + Right (text "(" <> operatorDoc <> text " " <> rightDoc <> text ")") + ParF innerValue -> do + innerDoc <- renderExprWith renderContext renderMode 0 innerValue + Right (parenthesizeDoc innerDoc) + LitF literalValue -> + Right (text (renderNormalizedLit literalValue)) + OverLitF literalValue -> + Right (text (renderNormalizedOverLit literalValue)) + IfF conditionValue thenValue elseValue -> do + conditionDoc <- renderExprWith renderContext renderMode 0 conditionValue + thenDoc <- renderExprWith renderContext renderMode 0 thenValue + elseDoc <- renderExprWith renderContext renderMode 0 elseValue + Right (wrapParen (parentPrecedence > 0) (text "if " <> conditionDoc <> text " then " <> thenDoc <> text " else " <> elseDoc)) + CaseF scrutineeValue branchValues -> + renderCaseExpression renderContext renderMode parentPrecedence scrutineeValue branchValues + DoF statementValues -> do + renderDoExpression renderContext renderMode parentPrecedence statementValues + NegF innerValue -> do + innerDoc <- renderExprWith renderContext renderMode 10 innerValue + Right (wrapParen (parentPrecedence > 9) (text "-" <> innerDoc)) + ExplicitListF valueList -> do + elementDocs <- traverse (renderExprWith renderContext renderMode 0) valueList + Right (text "[" <> intercalateDoc (text ", ") elementDocs <> text "]") + ExplicitTupleF boxity slots -> do + slotDocs <- traverse (traverse (renderExprWith renderContext renderMode 0)) slots + let delimiters = + case boxity of + BoxedTuple -> ("(", ")") + UnboxedTuple -> ("(#", "#)") + Right + ( text (fst delimiters) + <> intercalateDoc (text ", ") (fmap (foldMap id) slotDocs) + <> text (snd delimiters) + ) + RecordConF constructorValue fieldValues -> + renderRecordLike renderContext renderMode constructorValue fieldValues + RecordUpdF recordValue fieldValues -> + renderRecordLike renderContext renderMode recordValue fieldValues + ArithSeqF arithSeqValue -> + renderArithSeq renderContext renderMode arithSeqValue + GuardedF {} -> + Left RenderGuardedExpression + ClausesF clauseValues -> + renderClausesExpression renderContext renderMode parentPrecedence clauseValues + MultiIfF guardedAlts -> + renderMultiIf renderContext renderMode parentPrecedence guardedAlts + ExprWithTySigF bodyValue typeTextValue -> do + bodyDoc <- renderExprWith renderContext renderMode 0 bodyValue + Right (wrapParen (parentPrecedence > 0) (bodyDoc <> text " :: " <> renderTypeText typeTextValue)) + AppTypeF functionValue typeTextValue -> do + functionDoc <- renderExprWith renderContext renderMode 10 functionValue + Right (wrapParen (parentPrecedence > 10) (functionDoc <> text " @" <> renderTypeText typeTextValue)) + +renderClausesExpression :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + Int -> + [([HsPatF], recursive)] -> + Either RenderRefusal document +renderClausesExpression renderContext renderMode parentPrecedence clauseValues = do + validClauses <- validateClauses clauseValues + renderAsPatternLambda <- + case validClauses of + [(patternValues, bodyValue)] + | not (all isLambdaBinderPattern patternValues) -> + not <$> isGuardedBody renderContext bodyValue + _ -> + Right False + if renderAsPatternLambda + then + case validClauses of + [(patternValues, bodyValue)] -> + renderPatternLambda renderContext renderMode parentPrecedence patternValues bodyValue + _ -> + Left RenderClausesShape + else + if all ((== 1) . length . fst) validClauses + then renderLambdaCase renderContext renderMode parentPrecedence validClauses + else renderLambdaCases renderContext renderMode parentPrecedence validClauses + +renderPatternLambda :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + Int -> + [HsPatF] -> + recursive -> + Either RenderRefusal document +renderPatternLambda renderContext renderMode parentPrecedence patternValues bodyValue = do + lhsDoc <- renderClausePatterns renderContext patternValues + bodyDoc <- renderExprWith renderContext renderMode 0 bodyValue + Right (wrapParen (parentPrecedence > 0) (text "\\" <> lhsDoc <> text " -> " <> bodyDoc)) + +renderLambdaCase :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + Int -> + [([HsPatF], recursive)] -> + Either RenderRefusal document +renderLambdaCase renderContext renderMode parentPrecedence clauseValues = do + altDocs <- traverse (renderLambdaCaseAlt renderContext renderMode) clauseValues + Right (wrapParen (parentPrecedence > 0) (renderBlock renderMode "\\case" altDocs)) + +renderLambdaCaseAlt :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + ([HsPatF], recursive) -> + Either RenderRefusal document +renderLambdaCaseAlt renderContext renderMode = \case + ([patternValue], bodyValue) -> do + patternDoc <- renderPat renderContext False patternValue + renderClauseArrow renderContext renderMode patternDoc bodyValue + _ -> + Left RenderClausesShape + +renderLambdaCases :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + Int -> + [([HsPatF], recursive)] -> + Either RenderRefusal document +renderLambdaCases renderContext renderMode parentPrecedence clauseValues = do + altDocs <- traverse (renderLambdaCasesAlt renderContext renderMode) clauseValues + Right (wrapParen (parentPrecedence > 0) (renderBlock renderMode "\\cases" altDocs)) + +renderLambdaCasesAlt :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + ([HsPatF], recursive) -> + Either RenderRefusal document +renderLambdaCasesAlt renderContext renderMode (patternValues, bodyValue) = do + lhsDoc <- renderClausePatterns renderContext patternValues + renderClauseArrow renderContext renderMode lhsDoc bodyValue + +renderClauseLhs :: + RenderDocument document => + RenderSource recursive -> + document -> + [HsPatF] -> + Either RenderRefusal document +renderClauseLhs renderContext headDoc patternValues = + (headDoc <+>) <$> renderClausePatterns renderContext patternValues + +renderClauseArrow :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + document -> + recursive -> + Either RenderRefusal document +renderClauseArrow = + renderClauseArrowCore + +renderClauseArrowCore :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + document -> + recursive -> + Either RenderRefusal document +renderClauseArrowCore renderContext renderMode lhsDoc bodyValue = do + bodyNode <- rsProjectNode renderContext bodyValue + case bodyNode of + GuardedF guardedAlts -> + renderGuardedCaseAlts renderContext renderMode lhsDoc guardedAlts + _ -> do + bodyDoc <- renderExprWith renderContext renderMode 0 bodyValue + Right (renderDelimitedExpression renderMode lhsDoc "->" bodyDoc) + +renderGuardedAlt :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + document -> + String -> + GuardedAltF recursive -> + Either RenderRefusal document +renderGuardedAlt renderContext renderMode prefixDoc delimiter guardedAlt = + case gaGuards guardedAlt of + [] -> + Left RenderGuardedExpression + guardStatements -> do + guardDoc <- renderGuardStatements renderContext renderMode guardStatements + bodyDoc <- renderExprWith renderContext renderMode 0 (gaBody guardedAlt) + Right (prefixDoc <> guardDoc <> text delimiter <> bodyDoc) + +renderOpChain :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + Int -> + recursive -> + [(recursive, recursive)] -> + Either RenderRefusal document +renderOpChain renderContext renderMode parentPrecedence firstOperand chainTail = do + firstDoc <- renderExprWith renderContext renderMode 1 firstOperand + tailDocs <- + traverse + ( \(operatorValue, operandValue) -> + (,) + <$> renderOperator renderContext operatorValue + <*> renderExprWith renderContext renderMode 1 operandValue + ) + chainTail + let chainDoc = + hsep + ( firstDoc + : foldMap + (\(operatorDoc, operandDoc) -> [operatorDoc, operandDoc]) + tailDocs + ) + Right (wrapParen (parentPrecedence > 0) chainDoc) + +renderCaseBranch :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + (HsPatF, recursive) -> + Either RenderRefusal document +renderCaseBranch renderContext renderMode (casePattern, branchValue) = do + patternDoc <- renderPat renderContext False casePattern + renderClauseArrow renderContext renderMode patternDoc branchValue + +renderCaseExpression :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + Int -> + recursive -> + [(HsPatF, recursive)] -> + Either RenderRefusal document +renderCaseExpression renderContext renderMode parentPrecedence scrutineeValue branchValues = do + scrutineeDoc <- renderExprWith renderContext renderMode 0 scrutineeValue + branchDocs <- traverse (renderCaseBranch renderContext renderMode) branchValues + Right + ( wrapParen + (parentPrecedence > 0) + ( case renderMode of + CompactRender -> + text "case " + <> scrutineeDoc + <> text " of { " + <> intercalateDoc (text "; ") branchDocs + <> text " }" + GeneratedRender -> + vcat + [ text "case " <> scrutineeDoc <> text " of", + nest 2 (vcat branchDocs) + ] + ) + ) + +renderGuardedCaseAlts :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + document -> + [GuardedAltF recursive] -> + Either RenderRefusal document +renderGuardedCaseAlts renderContext renderMode patternDoc guardedAlts = + case guardedAlts of + [] -> + Left RenderGuardedExpression + [GuardedAltF [] bodyValue] -> do + bodyDoc <- renderExprWith renderContext renderMode 0 bodyValue + Right (patternDoc <> text " -> " <> bodyDoc) + _ -> do + altDocs <- traverse (renderGuardedCaseAlt renderContext renderMode) guardedAlts + Right (patternDoc <> hcat altDocs) + +renderGuardedCaseAlt :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + GuardedAltF recursive -> + Either RenderRefusal document +renderGuardedCaseAlt renderContext renderMode = + renderGuardedAlt renderContext renderMode (text " | ") " -> " + +renderMultiIf :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + Int -> + [GuardedAltF recursive] -> + Either RenderRefusal document +renderMultiIf renderContext renderMode parentPrecedence guardedAlts = + case guardedAlts of + [] -> + Left RenderGuardedExpression + firstAlt : restAlts -> do + firstDoc <- renderMultiIfAlt renderContext renderMode (text "if ") firstAlt + restDocs <- traverse (renderMultiIfAlt renderContext renderMode (text " ")) restAlts + Right + ( wrapParen + (parentPrecedence > 0) + ( case renderMode of + CompactRender -> hcat (firstDoc : restDocs) + GeneratedRender -> vcat (firstDoc : restDocs) + ) + ) + +renderMultiIfAlt :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + document -> + GuardedAltF recursive -> + Either RenderRefusal document +renderMultiIfAlt renderContext renderMode prefixDoc = + renderGuardedAlt renderContext renderMode (prefixDoc <> text "| ") " -> " + +renderDoExpression :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + Int -> + [HsStmtF recursive] -> + Either RenderRefusal document +renderDoExpression renderContext renderMode parentPrecedence statementValues = do + statementDocs <- traverse (renderDoStatement renderContext renderMode) statementValues + Right (wrapParen (parentPrecedence > 0) (renderBlock renderMode "do" statementDocs)) + +renderDoStatement :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + HsStmtF recursive -> + Either RenderRefusal document +renderDoStatement renderContext renderMode = \case + BindStmtF bindPattern rhsValue -> do + patternDoc <- renderPat renderContext False bindPattern + rhsDoc <- renderExprWith renderContext renderMode 0 rhsValue + Right (patternDoc <> text " <- " <> rhsDoc) + BodyStmtF exprValue -> + renderExprWith renderContext renderMode 0 exprValue + LetStmtF _ bindingValues -> + renderLetStatement renderContext renderMode bindingValues + +renderLetStatement :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + LocalBindingRows recursive -> + Either RenderRefusal document +renderLetStatement renderContext renderMode bindingValues = do + bindingDocs <- traverse (renderLetBinding renderContext renderMode) bindingValues + Right (renderBlock renderMode "let" bindingDocs) + +renderLetExpression :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + Int -> + LocalBindingRows recursive -> + recursive -> + Either RenderRefusal document +renderLetExpression renderContext renderMode parentPrecedence bindingValues bodyValue = do + bindingDocs <- traverse (renderLetBinding renderContext renderMode) bindingValues + bodyDoc <- renderExprWith renderContext renderMode 0 bodyValue + Right $ + wrapParen (parentPrecedence > 0) $ + case renderMode of + CompactRender -> + text "let " <> intercalateDoc (text "; ") bindingDocs <> text " in " <> bodyDoc + GeneratedRender -> + vcat + [ text "let", + nest 2 (vcat bindingDocs), + text "in " <> bodyDoc + ] + +renderLetBinding :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + (HsPatF, recursive) -> + Either RenderRefusal document +renderLetBinding renderContext renderMode (bindingPattern, rhsValue) = do + patternDoc <- renderPat renderContext False bindingPattern + rhsDoc <- renderExprWith renderContext renderMode 0 rhsValue + Right + (renderDelimitedExpression renderMode patternDoc "=" rhsDoc) + +renderGuardStatements :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + [HsGuardStmtF recursive] -> + Either RenderRefusal document +renderGuardStatements renderContext renderMode guardStatements = do + guardDocs <- traverse (renderGuardStatement renderContext renderMode) guardStatements + Right (intercalateDoc (text ", ") guardDocs) + +renderGuardStatement :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + HsGuardStmtF recursive -> + Either RenderRefusal document +renderGuardStatement renderContext renderMode = \case + GuardBoolF exprValue -> + renderExprWith renderContext renderMode 0 exprValue + GuardPatF patternValue rhsValue -> do + patternDoc <- renderPat renderContext False patternValue + rhsDoc <- renderExprWith renderContext renderMode 0 rhsValue + Right (patternDoc <+> text "<-" <+> rhsDoc) + GuardLetF _ bindingValues -> + renderLetStatement renderContext renderMode bindingValues + +renderRecordLike :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + recursive -> + [(NormalizedFieldLabel, recursive)] -> + Either RenderRefusal document +renderRecordLike renderContext renderMode headValue fieldValues = do + headDoc <- renderExprWith renderContext renderMode 11 headValue + fieldDocs <- traverse (renderField renderContext renderMode) fieldValues + Right (renderRecordExpression renderMode headDoc fieldDocs) + +renderField :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + (NormalizedFieldLabel, recursive) -> + Either RenderRefusal document +renderField renderContext renderMode (fieldLabelValue, fieldValue) = do + fieldDoc <- renderExprWith renderContext renderMode 0 fieldValue + Right (text (nflSelector fieldLabelValue) <> text " = " <> fieldDoc) + +renderRecordExpression :: + RenderDocument document => + RenderMode -> + document -> + [document] -> + document +renderRecordExpression renderMode headDoc fieldDocs = + case (renderMode, fieldDocs) of + (CompactRender, _) -> + headDoc <> text " { " <> intercalateDoc (text ", ") fieldDocs <> text " }" + (GeneratedRender, []) -> + headDoc <> text " {}" + (GeneratedRender, firstField : remainingFields) -> + vcat + [ headDoc, + nest 2 + ( vcat + ( (text "{ " <> firstField) + : fmap (text ", " <>) remainingFields + <> [text "}"] + ) + ) + ] + +renderArithSeq :: + RenderDocument document => + RenderSource recursive -> + RenderMode -> + NormalizedArithSeq recursive -> + Either RenderRefusal document +renderArithSeq renderContext renderMode = \case + ArithSeqFrom fromValue -> do + fromDoc <- renderExprWith renderContext renderMode 0 fromValue + Right (text "[" <> fromDoc <> text " ..]") + ArithSeqFromThen fromValue thenValue -> do + fromDoc <- renderExprWith renderContext renderMode 0 fromValue + thenDoc <- renderExprWith renderContext renderMode 0 thenValue + Right (text "[" <> fromDoc <> text ", " <> thenDoc <> text " ..]") + ArithSeqFromTo fromValue toValue -> do + fromDoc <- renderExprWith renderContext renderMode 0 fromValue + toDoc <- renderExprWith renderContext renderMode 0 toValue + Right (text "[" <> fromDoc <> text " .. " <> toDoc <> text "]") + ArithSeqFromThenTo fromValue thenValue toValue -> do + fromDoc <- renderExprWith renderContext renderMode 0 fromValue + thenDoc <- renderExprWith renderContext renderMode 0 thenValue + toDoc <- renderExprWith renderContext renderMode 0 toValue + Right (text "[" <> fromDoc <> text ", " <> thenDoc <> text " .. " <> toDoc <> text "]") diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Literal.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Literal.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Literal.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moonlight.Pale.Ghc.Expr.Render.Literal + ( renderNormalizedLit, + renderNormalizedOverLit, + renderExactIntegral, + renderExactFractional, + renderExactRational, + finiteDecimal, + factorMultiplicity, + renderScaledDecimal, + renderExponent, + renderPrimitiveByte + ) +where + +import Data.ByteString qualified as ByteString +import Data.Char qualified as Char +import Data.Ratio (denominator, numerator) +import Data.Word (Word8) +import GHC.Types.SourceText (FractionalExponentBase (..)) +import Numeric (showHex) +import Moonlight.Pale.Ghc.Expr.Syntax +renderNormalizedLit :: NormalizedLit -> String +renderNormalizedLit = \case + NormalizedChar value -> show value + NormalizedCharPrim value -> show value <> "#" + NormalizedString value -> show value + NormalizedMultilineString value -> show value + NormalizedStringPrim value -> "\"" <> foldMap renderPrimitiveByte (ByteString.unpack value) <> "\"#" + NormalizedInt value -> renderExactIntegral "" value + NormalizedIntPrim value -> renderExactIntegral "#" value + NormalizedWordPrim value -> renderExactIntegral "##" value + NormalizedInt8Prim value -> renderExactIntegral "#Int8" value + NormalizedInt16Prim value -> renderExactIntegral "#Int16" value + NormalizedInt32Prim value -> renderExactIntegral "#Int32" value + NormalizedInt64Prim value -> renderExactIntegral "#Int64" value + NormalizedWord8Prim value -> renderExactIntegral "#Word8" value + NormalizedWord16Prim value -> renderExactIntegral "#Word16" value + NormalizedWord32Prim value -> renderExactIntegral "#Word32" value + NormalizedWord64Prim value -> renderExactIntegral "#Word64" value + NormalizedFloatPrim value -> renderExactFractional "#" value + NormalizedDoublePrim value -> renderExactFractional "##" value + +renderNormalizedOverLit :: NormalizedOverLit -> String +renderNormalizedOverLit = \case + NormalizedIntegralOverLit value -> renderExactIntegral "" value + NormalizedFractionalOverLit value -> renderExactFractional "" value + NormalizedStringOverLit value -> show value + +renderExactIntegral :: String -> ExactIntegral -> String +renderExactIntegral suffix exactValue = + maybe + ( [ '-' | exactIntegralNegative exactValue ] + <> show (exactIntegralValue exactValue) + <> suffix + ) + id + (exactIntegralSource exactValue) + +renderExactFractional :: String -> ExactFractional -> String +renderExactFractional suffix exactValue = + maybe + ( [ '-' | exactFractionalNegative exactValue ] + <> renderExactRational (exactFractionalSignificand exactValue) + <> renderExponent (exactFractionalBase exactValue) (exactFractionalExponent exactValue) + <> suffix + ) + id + (exactFractionalSource exactValue) + +renderExactRational :: Rational -> String +renderExactRational rationalValue = + maybe + ("(" <> show (numerator rationalValue) <> " / " <> show (denominator rationalValue) <> ")") + id + (finiteDecimal rationalValue) + +finiteDecimal :: Rational -> Maybe String +finiteDecimal rationalValue = + let denominatorValue = denominator rationalValue + (twoCount, afterTwos) = factorMultiplicity 2 denominatorValue + (fiveCount, residualDenominator) = factorMultiplicity 5 afterTwos + decimalPlaces = max twoCount fiveCount + scaledNumerator = + numerator rationalValue + * (2 ^ (decimalPlaces - twoCount)) + * (5 ^ (decimalPlaces - fiveCount)) + in if residualDenominator /= 1 + then Nothing + else Just (renderScaledDecimal decimalPlaces scaledNumerator) + +factorMultiplicity :: Integer -> Integer -> (Int, Integer) +factorMultiplicity factorValue value + | value `mod` factorValue == 0 = + let (remainingCount, residualValue) = + factorMultiplicity factorValue (value `div` factorValue) + in (remainingCount + 1, residualValue) + | otherwise = + (0, value) + +renderScaledDecimal :: Int -> Integer -> String +renderScaledDecimal decimalPlaces scaledNumerator + | decimalPlaces == 0 = + show scaledNumerator <> ".0" + | otherwise = + let signPrefix = ['-' | scaledNumerator < 0] + unsignedDigits = show (abs scaledNumerator) + paddedDigits = + replicate (max 0 (decimalPlaces + 1 - length unsignedDigits)) '0' + <> unsignedDigits + splitIndex = length paddedDigits - decimalPlaces + (wholeDigits, fractionalDigits) = splitAt splitIndex paddedDigits + in signPrefix <> wholeDigits <> "." <> fractionalDigits + +renderExponent :: FractionalExponentBase -> Integer -> String +renderExponent exponentBase exponentValue = + case (exponentBase, exponentValue) of + (_, 0) -> "" + (Base10, _) -> "e" <> show exponentValue + (Base2, _) -> "p" <> show exponentValue + +renderPrimitiveByte :: Word8 -> String +renderPrimitiveByte byteValue = + case Char.chr (fromIntegral byteValue) of + '"' -> "\\\"" + '\\' -> "\\\\" + characterValue + | byteValue >= 32 && byteValue <= 126 -> + [characterValue] + | otherwise -> + "\\x" <> showHex byteValue "" <> "\\&" diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Module.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Module.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Module.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moonlight.Pale.Ghc.Expr.Render.Module + ( ModuleRenderContext (..), + RenderTarget (..), + renderSourceWith, + renderRewriteModuleSource, + renderModuleDeclaration, + renderConvertedModuleWith + ) +where + +import Data.Foldable qualified as Foldable +import Data.Kind (Type) +import Moonlight.Core (Pattern (..)) +import Moonlight.Pale.Ghc.Expr.Convert.Coalgebra + ( Binding (..), + ConvertedInstanceDeclaration (..), + ConvertedModule (..), + ModuleDeclaration (..), + convertedBindingValue, + convertedModuleBindingSites, + tlbBinding, + ) +import Moonlight.Pale.Ghc.Expr.Render.Analysis +import Moonlight.Pale.Ghc.Expr.Render.Binding +import Moonlight.Pale.Ghc.Expr.Render.Document +import Moonlight.Pale.Ghc.Expr.Render.Expression +import Moonlight.Pale.Ghc.Expr.Render.Name +import Moonlight.Pale.Ghc.Expr.Render.Refusal +import Moonlight.Pale.Ghc.Expr.Syntax + +type ModuleRenderContext :: Type +data ModuleRenderContext = ModuleRenderContext + { moduleHeaderPrefix :: !String, + moduleRenderedName :: !(Maybe String) + } + deriving stock (Eq, Ord, Show) + +type RenderTarget :: Type +data RenderTarget + = RenderAnnotatedExpression !Expr + | RenderRewriteExpression !(Pattern HsExprF) + | RenderNamedRewriteBinding !String !(Pattern HsExprF) + | RenderSourceBinding !Binding + | RenderRewriteModule !ModuleRenderContext ![(String, Pattern HsExprF)] + | RenderConvertedModule !ModuleRenderContext !ConvertedModule + +renderSourceWith :: + RenderDocument document => + RenderMode -> + RenderTarget -> + Either RenderRefusal document +renderSourceWith renderMode = \case + RenderAnnotatedExpression expressionValue -> do + expressionRenderSource <- + prepareRenderSource (Right . exprNode) [] [expressionValue] + renderExprWith + expressionRenderSource + renderMode + 0 + expressionValue + RenderRewriteExpression expressionValue -> do + expressionRenderSource <- patternRenderSource expressionValue + renderExprWith + expressionRenderSource + renderMode + 0 + expressionValue + RenderNamedRewriteBinding bindingName bindingTerm -> do + expressionRenderSource <- patternRenderSource bindingTerm + renderTopLevelBindingWith + expressionRenderSource + renderMode + bindingName + bindingTerm + RenderSourceBinding bindingValue -> + renderBindingWith renderMode bindingValue + RenderRewriteModule moduleContext renderedBindings -> + renderRewriteModuleSource renderMode moduleContext renderedBindings + RenderConvertedModule moduleContext convertedModule -> + renderConvertedModuleWith renderMode moduleContext convertedModule + +renderRewriteModuleSource :: + RenderDocument document => + RenderMode -> + ModuleRenderContext -> + [(String, Pattern HsExprF)] -> + Either RenderRefusal document +renderRewriteModuleSource renderMode moduleContext renderedBindings = do + bindingDocuments <- + traverse + ( \(bindingName, bindingTerm) -> do + expressionRenderSource <- patternRenderSource bindingTerm + renderTopLevelBindingWith + expressionRenderSource + renderMode + bindingName + bindingTerm + ) + renderedBindings + let headerPrefix = moduleHeaderPrefix moduleContext + let prefixValue = + if null headerPrefix + then + requiredLanguageHeader (fmap snd renderedBindings) + <> maybe + "" + (\moduleNameValue -> "module " <> moduleNameValue <> " where\n\n") + (moduleRenderedName moduleContext) + else headerPrefix + Right + ( text prefixValue + <> intercalateDoc (text "\n\n") bindingDocuments + <> text "\n" + ) + +renderModuleDeclaration :: + RenderDocument document => + RenderMode -> + ModuleDeclaration -> + Either RenderRefusal document +renderModuleDeclaration renderMode = \case + ValueDeclaration bindingValue -> + renderBindingWith renderMode (tlbBinding bindingValue) + TypeSignatureDeclaration signature -> + Right (text (renderTypeSignature signature)) + FixityDeclarationNode declaration -> + Right (text (renderFixityDeclaration declaration)) + InstanceDeclarationNode instanceDeclaration -> + Right (text (convertedInstanceSource instanceDeclaration)) + OpaqueDeclaration _ _ declarationSource -> + Right (text declarationSource) + +renderConvertedModuleWith :: + RenderDocument document => + RenderMode -> + ModuleRenderContext -> + ConvertedModule -> + Either RenderRefusal document +renderConvertedModuleWith renderMode moduleContext convertedModule = do + declarationDocuments <- + traverse + (renderModuleDeclaration renderMode) + (Foldable.toList (cmDeclarations convertedModule)) + let bindings = + fmap convertedBindingValue (convertedModuleBindingSites convertedModule) + headerPrefix = + moduleHeaderPrefix moduleContext + let prefixValue = + if null headerPrefix + then + requiredConvertedLanguageHeader bindings + <> maybe + "" + (\moduleNameValue -> "module " <> moduleNameValue <> " where\n\n") + (moduleRenderedName moduleContext) + else headerPrefix + Right + ( text prefixValue + <> intercalateDoc (text "\n\n") declarationDocuments + <> text "\n" + ) diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Name.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Name.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Name.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moonlight.Pale.Ghc.Expr.Render.Name + ( renderFixityDeclaration, + renderTypeSignature, + renderSignatureName, + renderOperator, + renderConName, + renderNameAtom, + renderVarRefAtom, + renderVarRefOperator, + renderVarRefName, + renderBinderAnn, + renderBinderSpelling, + renderBinderName, + renderDefinitionName, + renderTypeText, + RenderNamePlan (..), + patternRenderSource, + bindingRenderSource, + prepareRenderSource, + allocateRenderName, + allocateAvailableSpelling, + collectGlobalSpellings, + allocateTermRenderNames + ) +where + +import Data.Char (isAlpha) +import Data.Foldable qualified as Foldable +import Data.Kind (Type) +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet +import Data.List (intercalate) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import GHC.Types.Name.Occurrence (isSymOcc, mkVarOcc, occNameString) +import GHC.Types.Name.Reader (RdrName, mkRdrUnqual, rdrNameOcc) +import Moonlight.Core (Pattern (..), binderIdKey) +import Moonlight.Pale.Ghc.Expr.Convert.Coalgebra (Binding (..)) +import Moonlight.Pale.Ghc.Expr.NameRender (renderRdrName) +import Moonlight.Pale.Ghc.Expr.Render.Annotation +import Moonlight.Pale.Ghc.Expr.Render.Carrier +import Moonlight.Pale.Ghc.Expr.Render.Document +import Moonlight.Pale.Ghc.Expr.Render.Refusal +import Moonlight.Pale.Ghc.Expr.Syntax + +renderFixityDeclaration :: FixityDeclaration -> String +renderFixityDeclaration declaration = + let keyword = + case fixityAssociativity declaration of + FixityLeft -> "infixl" + FixityRight -> "infixr" + FixityNone -> "infix" + in keyword + <> " " + <> show (fixityPrecedence declaration) + <> " " + <> intercalate ", " (fmap renderRdrName (NonEmpty.toList (fixityOperators declaration))) + +renderTypeSignature :: TypeSignature -> String +renderTypeSignature signature = + intercalate ", " (fmap renderSignatureName (NonEmpty.toList (typeSignatureNames signature))) + <> " :: " + <> nttText (typeSignatureType signature) + +renderSignatureName :: RdrName -> String +renderSignatureName nameValue = + if isSymOcc (rdrNameOcc nameValue) + then "(" <> renderRdrName nameValue <> ")" + else renderRdrName nameValue + +renderOperator :: + RenderDocument document => + RenderSource recursive -> + recursive -> + Either RenderRefusal document +renderOperator renderContext operatorValue = do + operatorNode <- rsProjectNode renderContext operatorValue + case operatorNode of + VarF variableReference -> + Right (renderVarRefOperator renderContext variableReference) + _ -> + Left RenderNonVarOperator + +renderConName :: + RenderDocument document => + RdrName -> + document +renderConName = renderNameAtom + +renderNameAtom :: + RenderDocument document => + RdrName -> + document +renderNameAtom nameValue = + if isSymOcc (rdrNameOcc nameValue) + then text ("(" <> renderRdrName nameValue <> ")") + else text (renderRdrName nameValue) + +renderVarRefAtom :: + RenderDocument document => + RenderSource recursive -> + HsVarRef -> + document +renderVarRefAtom renderContext = + renderNameAtom . renderVarRefName renderContext + +renderVarRefOperator :: + RenderDocument document => + RenderSource recursive -> + HsVarRef -> + document +renderVarRefOperator renderContext variableReference = + let nameValue = renderVarRefName renderContext variableReference + in if isSymOcc (rdrNameOcc nameValue) + then text (renderRdrName nameValue) + else text ("`" <> renderRdrName nameValue <> "`") + +renderVarRefName :: RenderSource recursive -> HsVarRef -> RdrName +renderVarRefName renderContext = \case + GlobalName globalName -> + globalName + LocalName binderAnn -> + renderBinderName renderContext binderAnn + +renderBinderAnn :: + RenderDocument document => + RenderSource recursive -> + BinderAnn -> + document +renderBinderAnn renderContext = + renderNameAtom . renderBinderName renderContext + +renderBinderSpelling :: RenderSource recursive -> BinderAnn -> String +renderBinderSpelling renderContext = + renderRdrName . renderBinderName renderContext + +renderBinderName :: RenderSource recursive -> BinderAnn -> RdrName +renderBinderName renderContext binderAnn = + IntMap.findWithDefault + (baName binderAnn) + (binderIdKey (baId binderAnn)) + (rsRenderNames renderContext) + +renderDefinitionName :: + RenderDocument document => + String -> + document +renderDefinitionName definitionName = + case definitionName of + headChar : _ + | isAlpha headChar || headChar == '_' -> + text definitionName + _ -> + text ("(" <> definitionName <> ")") + +renderTypeText :: + RenderDocument document => + NormalizedTypeText -> + document +renderTypeText = + text . nttText + +type RenderNamePlan :: Type +data RenderNamePlan = RenderNamePlan + { rnpSeenBinders :: !IntSet, + rnpNames :: !(IntMap RdrName), + rnpUsedSpellings :: !(Map String ()), + rnpNextSuffixes :: !(Map String Int) + } + +patternRenderSource :: Pattern HsExprF -> Either RenderRefusal (RenderSource (Pattern HsExprF)) +patternRenderSource expressionValue = + prepareRenderSource projectPatternNode [] [expressionValue] + +bindingRenderSource :: Binding -> Either RenderRefusal (RenderSource Expr) +bindingRenderSource bindingValue = + prepareRenderSource + (Right . exprNode) + (bindingRenderAnnotations bindingValue) + (bindingRootExpressions bindingValue) + +prepareRenderSource :: + RenderNodeProjection recursive -> + [BinderAnn] -> + [recursive] -> + Either RenderRefusal (RenderSource recursive) +prepareRenderSource projectNode outerBindingAnnotations rootTerms = do + globalSpellings <- + Foldable.foldlM + (collectGlobalSpellings projectNode) + Map.empty + rootTerms + let !outerNamePlan = + Foldable.foldl' + allocateRenderName + RenderNamePlan + { rnpSeenBinders = IntSet.empty, + rnpNames = IntMap.empty, + rnpUsedSpellings = globalSpellings, + rnpNextSuffixes = Map.empty + } + outerBindingAnnotations + namePlan <- + Foldable.foldlM + (allocateTermRenderNames projectNode) + outerNamePlan + rootTerms + Right + RenderSource + { rsProjectNode = projectNode, + rsRenderNames = rnpNames namePlan + } + +allocateRenderName :: RenderNamePlan -> BinderAnn -> RenderNamePlan +allocateRenderName namePlan binderAnn = + let binderKey = binderIdKey (baId binderAnn) + in if IntSet.member binderKey (rnpSeenBinders namePlan) + then namePlan + else + let preferredName = occNameString (rdrNameOcc (baName binderAnn)) + currentSuffix = + Map.findWithDefault 0 preferredName (rnpNextSuffixes namePlan) + (chosenSpelling, nextSuffix) = + allocateAvailableSpelling + (rnpUsedSpellings namePlan) + currentSuffix + preferredName + chosenName = mkRdrUnqual (mkVarOcc chosenSpelling) + renderNameOverrides = + if chosenName == baName binderAnn + then rnpNames namePlan + else IntMap.insert binderKey chosenName (rnpNames namePlan) + nextSuffixes = + if nextSuffix == currentSuffix + then rnpNextSuffixes namePlan + else + Map.insert + preferredName + nextSuffix + (rnpNextSuffixes namePlan) + in namePlan + { rnpSeenBinders = + IntSet.insert binderKey (rnpSeenBinders namePlan), + rnpNames = renderNameOverrides, + rnpUsedSpellings = Map.insert chosenSpelling () (rnpUsedSpellings namePlan), + rnpNextSuffixes = nextSuffixes + } + +allocateAvailableSpelling :: Map String () -> Int -> String -> (String, Int) +allocateAvailableSpelling usedSpellings nextSuffix initialSpelling + | Map.notMember initialSpelling usedSpellings = + (initialSpelling, nextSuffix) + | otherwise = + firstUnusedSuffix nextSuffix + where + firstUnusedSuffix suffix = + let candidateSpelling = + initialSpelling <> "_" <> show suffix + in if Map.member candidateSpelling usedSpellings + then firstUnusedSuffix (suffix + 1) + else (candidateSpelling, suffix + 1) + +collectGlobalSpellings :: + RenderNodeProjection recursive -> + Map String () -> + recursive -> + Either RenderRefusal (Map String ()) +collectGlobalSpellings projectNode accumulatedSpellings expressionValue = do + nodeValue <- projectNode expressionValue + let !nodeSpellings = + case nodeValue of + VarF (GlobalName globalName) -> + Map.insert (renderRdrName globalName) () accumulatedSpellings + _ -> + accumulatedSpellings + Foldable.foldlM + (collectGlobalSpellings projectNode) + nodeSpellings + nodeValue + +allocateTermRenderNames :: + RenderNodeProjection recursive -> + RenderNamePlan -> + recursive -> + Either RenderRefusal RenderNamePlan +allocateTermRenderNames projectNode namePlan expressionValue = do + nodeValue <- projectNode expressionValue + let !nodeNamePlan = + Foldable.foldl' + allocateRenderName + namePlan + (nodeBindingAnnotations nodeValue) + Foldable.foldlM + (allocateTermRenderNames projectNode) + nodeNamePlan + nodeValue diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Pattern.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Pattern.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Pattern.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moonlight.Pale.Ghc.Expr.Render.Pattern + ( renderClausePatterns, + renderPat, + renderRecordPattern, + renderRecordPatternItem + ) +where + +import GHC.Types.Name.Occurrence (isSymOcc) +import GHC.Types.Name.Reader (RdrName, rdrNameOcc) +import Moonlight.Pale.Ghc.Expr.NameRender (renderRdrName) +import Moonlight.Pale.Ghc.Expr.Render.Carrier +import Moonlight.Pale.Ghc.Expr.Render.Document +import Moonlight.Pale.Ghc.Expr.Render.Literal +import Moonlight.Pale.Ghc.Expr.Render.Name +import Moonlight.Pale.Ghc.Expr.Render.Refusal +import Moonlight.Pale.Ghc.Expr.Syntax + +renderClausePatterns :: + RenderDocument document => + RenderSource recursive -> + [HsPatF] -> + Either RenderRefusal document +renderClausePatterns renderContext patternValues = do + patternDocs <- traverse (renderPat renderContext True) patternValues + Right (intercalateDoc (text " ") patternDocs) + +renderPat :: + RenderDocument document => + RenderSource recursive -> + Bool -> + HsPatF -> + Either RenderRefusal document +renderPat renderContext atomicContext = \case + PVarP binderAnn -> + Right (renderBinderAnn renderContext binderAnn) + PWildP -> + Right (text "_") + PConP conName subPatterns -> + case subPatterns of + [] -> + Right (renderConName conName) + [leftPattern, rightPattern] + | isSymOcc (rdrNameOcc conName) -> do + leftDoc <- renderPat renderContext True leftPattern + rightDoc <- renderPat renderContext True rightPattern + Right (wrapParen atomicContext (leftDoc <> text (" " <> renderRdrName conName <> " ") <> rightDoc)) + _ -> do + argDocs <- traverse (renderPat renderContext True) subPatterns + Right (wrapParen atomicContext (intercalateDoc (text " ") (renderConName conName : argDocs))) + PTupleP boxity subPatterns -> do + componentDocs <- traverse (renderPat renderContext False) subPatterns + let delimiters = + case boxity of + BoxedTuple -> ("(", ")") + UnboxedTuple -> ("(#", "#)") + Right (text (fst delimiters) <> intercalateDoc (text ", ") componentDocs <> text (snd delimiters)) + PListP subPatterns -> do + componentDocs <- traverse (renderPat renderContext False) subPatterns + Right (text "[" <> intercalateDoc (text ", ") componentDocs <> text "]") + PLitP literalValue -> + Right (text (renderNormalizedLit literalValue)) + POverLitP literalValue -> + Right (text (renderNormalizedOverLit literalValue)) + PAsP binderAnn subPattern -> do + subDoc <- renderPat renderContext True subPattern + Right (renderBinderAnn renderContext binderAnn <> text "@" <> subDoc) + PBangP subPattern -> do + subDoc <- renderPat renderContext True subPattern + Right (text "!" <> subDoc) + PLazyP subPattern -> do + subDoc <- renderPat renderContext True subPattern + Right (text "~" <> subDoc) + PParP subPattern -> do + subDoc <- renderPat renderContext False subPattern + Right (parenthesizeDoc subDoc) + PRecP conName fieldPatterns -> + renderRecordPattern renderContext conName fieldPatterns + +renderRecordPattern :: + RenderDocument document => + RenderSource recursive -> + RdrName -> + [HsRecPatItem] -> + Either RenderRefusal document +renderRecordPattern renderContext conName recordItems = + case recordItems of + [] -> + Right (renderConName conName <> text " {}") + _ -> do + itemDocuments <- + traverse (renderRecordPatternItem renderContext) recordItems + Right + ( renderConName conName + <> text " {" + <> intercalateDoc (text ", ") itemDocuments + <> text "}" + ) + +renderRecordPatternItem :: + RenderDocument document => + RenderSource recursive -> + HsRecPatItem -> + Either RenderRefusal document +renderRecordPatternItem renderContext = \case + HsRecPatField fieldName (HsRecPatExplicit fieldPattern) -> do + fieldDocument <- renderPat renderContext False fieldPattern + Right + ( text (renderRdrName fieldName) + <> text " = " + <> fieldDocument + ) + HsRecPatField fieldName (HsRecPatPun _) -> + Right (text (renderRdrName fieldName)) + HsRecPatWildcard _ _ -> + Right (text "..") diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Refusal.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Refusal.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Refusal.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moonlight.Pale.Ghc.Expr.Render.Refusal + ( RenderRefusal (..) + ) +where + +import Data.Kind (Type) +type RenderRefusal :: Type +data RenderRefusal + = RenderGuardedExpression + | RenderPatternVariable + | RenderNonVarOperator + | RenderEmptyBindingName + | RenderClausesShape + deriving stock (Eq, Ord, Show) diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Scope.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Scope.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Scope.hs @@ -0,0 +1,514 @@ +module Moonlight.Pale.Ghc.Expr.Scope + ( ScopeId, + ScopeIdFailure (..), + ScopeCtx (..), + ScopeIndex, + ScopeIndexFailure (..), + ScopeLookupFailure (..), + FreeScopeSummary, + mkScopeId, + scopeIdKey, + rootScopeId, + mkScopeIndex, + scopeIndexRoot, + scopeParentId, + scopeDepthOf, + scopeIsAncestorOf, + scopeComparable, + scopeLca, + scopeCtxLeq, + scopeCtxMeet, + scopeCtxJoin, + scopeObservedCount, + scopeObservedContexts, + scopeTopCtx, + scopeBottomCtx, + binderIntroScope, + binderSiteScope, + emptyFreeScopeSummary, + singletonFreeScopeSummary, + mergeFreeScopeSummary, + mergeFreeScopeSummaryBy, + mergeFreeScopeSummaryByEither, + deleteFreeScopeSummary, + freeScopeSummaryContains, + freeScopeSummarySize, + freeScopeSummaryToList, + freeScopeSupportAnchor, + ) +where + +import Control.Monad (foldM, when) +import Data.Foldable (traverse_) +import Data.IntMap.Strict qualified as IntMap +import Data.Kind (Type) +import Data.Primitive.SmallArray + ( SmallArray, + indexSmallArray, + sizeofSmallArray, + smallArrayFromList, + ) +import Data.Vector (Vector) +import Data.Vector qualified as V +import Data.Void (absurd) +import Moonlight.Core (BinderId (..), binderIdKey) + +type ScopeId :: Type +newtype ScopeId = ScopeId Int + deriving stock (Eq, Ord, Show) + +type ScopeIndex :: Type +data ScopeIndex = ScopeIndex + { siParent :: !(Vector Int), + siDepth :: !(Vector Int), + siSubtreeEnd :: !(Vector Int), + siLift :: !(Vector (Vector Int)), + siHasBranch :: !Bool, + siDeepest :: !ScopeId, + siRoot :: !ScopeId, + siBinderIntro :: !(Vector ScopeId) + } + deriving stock (Eq, Ord, Show) + +type FreeScopeSummary :: Type +newtype FreeScopeSummary = FreeScopeSummary (SmallArray ScopeId) + +instance Eq FreeScopeSummary where + FreeScopeSummary leftArray == FreeScopeSummary rightArray = + scopeArrayToList leftArray == scopeArrayToList rightArray + +instance Ord FreeScopeSummary where + compare (FreeScopeSummary leftArray) (FreeScopeSummary rightArray) = + compare (scopeArrayToList leftArray) (scopeArrayToList rightArray) + +instance Show FreeScopeSummary where + showsPrec precedence (FreeScopeSummary scopeArray) = + showParen + (precedence > 10) + (showString "FreeScopeSummary " . shows (scopeArrayToList scopeArray)) + +scopeArrayToList :: SmallArray ScopeId -> [ScopeId] +scopeArrayToList scopeArray = + fmap (indexSmallArray scopeArray) [0 .. sizeofSmallArray scopeArray - 1] + +type ScopeIdFailure :: Type +data ScopeIdFailure + = NegativeScopeId !Int + deriving stock (Eq, Ord, Show) + +type ScopeCtx :: Type +data ScopeCtx + = ActualScope !ScopeId + | IncompatibleScope + deriving stock (Eq, Ord, Show) + +type ScopeLookupFailure :: Type +data ScopeLookupFailure + = ScopeIdOutsideIndex !ScopeId !Int + | BinderIdOutsideIndex !BinderId !Int + | ScopeLiftLevelOutsideIndex !Int !Int + deriving stock (Eq, Ord, Show) + +type ScopeIndexFailure :: Type +data ScopeIndexFailure + = ScopeIndexEmpty + | ScopeRootParentInvalid !Int + | ScopeParentEdgeInvalid !ScopeId !Int + | ScopeBinderIntroInvalid !BinderId !Int + | ScopeSubtreeEndMissing !ScopeId + | ScopeLiftMissing !ScopeId + | ScopeParentNotPreorder !ScopeId !Int + deriving stock (Eq, Ord, Show) + +mkScopeId :: Int -> Either ScopeIdFailure ScopeId +mkScopeId scopeKey + | scopeKey < 0 = + Left (NegativeScopeId scopeKey) + | otherwise = + Right (ScopeId scopeKey) + +scopeIdKey :: ScopeId -> Int +scopeIdKey (ScopeId scopeKey) = + scopeKey + +rootScopeId :: ScopeId +rootScopeId = + ScopeId 0 + +mkScopeIndex :: Vector Int -> Vector Int -> Either ScopeIndexFailure ScopeIndex +mkScopeIndex parentVector binderIntroVector = do + case V.toList parentVector of + [] -> + Left ScopeIndexEmpty + rootParent : _ -> + when (rootParent /= 0) (Left (ScopeRootParentInvalid rootParent)) + traverse_ validateParentEdge (zip [1 ..] (drop 1 (V.toList parentVector))) + traverse_ validateBinderIntro (zip [0 ..] (V.toList binderIntroVector)) + preorder <- buildPreorderIndex parentVector + liftVector <- buildLift parentVector + pure + ScopeIndex + { siParent = parentVector, + siDepth = preorderDepth preorder, + siSubtreeEnd = preorderSubtreeEnd preorder, + siLift = liftVector, + siHasBranch = preorderHasBranch preorder, + siDeepest = preorderDeepest preorder, + siRoot = rootScopeId, + siBinderIntro = V.map ScopeId binderIntroVector + } + where + validateParentEdge (scopeKey, parentKey) = + when (parentKey < 0 || parentKey >= scopeKey) $ + Left (ScopeParentEdgeInvalid (ScopeId scopeKey) parentKey) + + validateBinderIntro (binderKey, introScopeKey) = + when (introScopeKey < 0 || introScopeKey >= V.length parentVector) $ + Left (ScopeBinderIntroInvalid (BinderId binderKey) introScopeKey) + +scopeIndexRoot :: ScopeIndex -> ScopeId +scopeIndexRoot = + siRoot + +scopeParentId :: ScopeIndex -> ScopeId -> Either ScopeLookupFailure ScopeId +scopeParentId scopeIndex scopeId = + ScopeId <$> scopeVectorValue ScopeIdOutsideIndex scopeId (siParent scopeIndex) + +scopeDepthOf :: ScopeIndex -> ScopeId -> Either ScopeLookupFailure Int +scopeDepthOf scopeIndex scopeId = + scopeVectorValue ScopeIdOutsideIndex scopeId (siDepth scopeIndex) + +scopeIsAncestorOf :: ScopeIndex -> ScopeId -> ScopeId -> Either ScopeLookupFailure Bool +scopeIsAncestorOf scopeIndex leftScope rightScope = do + leftEnd <- scopeVectorValue ScopeIdOutsideIndex leftScope (siSubtreeEnd scopeIndex) + _ <- scopeVectorValue ScopeIdOutsideIndex rightScope (siSubtreeEnd scopeIndex) + let leftKey = scopeIdKey leftScope + rightKey = scopeIdKey rightScope + pure (leftKey <= rightKey && rightKey < leftEnd) + +scopeComparable :: ScopeIndex -> ScopeId -> ScopeId -> Either ScopeLookupFailure Bool +scopeComparable scopeIndex leftScope rightScope = + (||) + <$> scopeIsAncestorOf scopeIndex leftScope rightScope + <*> scopeIsAncestorOf scopeIndex rightScope leftScope + +scopeLca :: ScopeIndex -> ScopeId -> ScopeId -> Either ScopeLookupFailure ScopeId +scopeLca scopeIndex leftScope rightScope = do + leftAncestor <- scopeIsAncestorOf scopeIndex leftScope rightScope + rightAncestor <- scopeIsAncestorOf scopeIndex rightScope leftScope + if leftAncestor + then pure leftScope + else + if rightAncestor + then pure rightScope + else scopeParentId scopeIndex =<< climb leftScope (V.length (siLift scopeIndex) - 1) + where + climb currentScope liftIndex + | liftIndex < 0 = + pure currentScope + | otherwise = do + ancestorScope <- liftAncestor scopeIndex liftIndex currentScope + ancestorOfRight <- scopeIsAncestorOf scopeIndex ancestorScope rightScope + if ancestorOfRight + then climb currentScope (liftIndex - 1) + else climb ancestorScope (liftIndex - 1) + +scopeCtxLeq :: ScopeIndex -> ScopeCtx -> ScopeCtx -> Either ScopeLookupFailure Bool +scopeCtxLeq _ IncompatibleScope IncompatibleScope = + Right True +scopeCtxLeq _ IncompatibleScope _ = + Right False +scopeCtxLeq _ _ IncompatibleScope = + Right True +scopeCtxLeq scopeIndex (ActualScope leftScope) (ActualScope rightScope) = + scopeIsAncestorOf scopeIndex leftScope rightScope + +scopeCtxMeet :: ScopeIndex -> ScopeCtx -> ScopeCtx -> Either ScopeLookupFailure ScopeCtx +scopeCtxMeet _ IncompatibleScope rightCtx = + Right rightCtx +scopeCtxMeet _ leftCtx IncompatibleScope = + Right leftCtx +scopeCtxMeet scopeIndex (ActualScope leftScope) (ActualScope rightScope) = + ActualScope <$> scopeLca scopeIndex leftScope rightScope + +scopeCtxJoin :: ScopeIndex -> ScopeCtx -> ScopeCtx -> Either ScopeLookupFailure ScopeCtx +scopeCtxJoin _ IncompatibleScope _ = + Right IncompatibleScope +scopeCtxJoin _ _ IncompatibleScope = + Right IncompatibleScope +scopeCtxJoin scopeIndex (ActualScope leftScope) (ActualScope rightScope) = do + leftAncestor <- scopeIsAncestorOf scopeIndex leftScope rightScope + rightAncestor <- scopeIsAncestorOf scopeIndex rightScope leftScope + pure $ + if leftAncestor + then ActualScope rightScope + else + if rightAncestor + then ActualScope leftScope + else IncompatibleScope + +scopeObservedCount :: ScopeIndex -> Int +scopeObservedCount = + V.length . siParent + +scopeObservedContexts :: ScopeIndex -> Either ScopeLookupFailure [ScopeCtx] +scopeObservedContexts scopeIndex = + Right + ( fmap (ActualScope . ScopeId) [0 .. V.length (siParent scopeIndex) - 1] + <> [IncompatibleScope | siHasBranch scopeIndex] + ) + +scopeTopCtx :: ScopeIndex -> Either ScopeLookupFailure ScopeCtx +scopeTopCtx scopeIndex = + Right + ( if siHasBranch scopeIndex + then IncompatibleScope + else ActualScope (siDeepest scopeIndex) + ) + +scopeBottomCtx :: ScopeIndex -> ScopeCtx +scopeBottomCtx = + ActualScope . siRoot + +binderIntroScope :: ScopeIndex -> BinderId -> Either ScopeLookupFailure ScopeId +binderIntroScope scopeIndex binderId = + binderVectorValue binderId (siBinderIntro scopeIndex) + +binderSiteScope :: ScopeIndex -> BinderId -> Either ScopeLookupFailure ScopeId +binderSiteScope scopeIndex binderId = + scopeParentId scopeIndex =<< binderIntroScope scopeIndex binderId + +emptyFreeScopeSummary :: FreeScopeSummary +emptyFreeScopeSummary = + FreeScopeSummary (smallArrayFromList []) + +singletonFreeScopeSummary :: ScopeId -> FreeScopeSummary +singletonFreeScopeSummary scopeId = + FreeScopeSummary (smallArrayFromList [scopeId]) + +mergeFreeScopeSummary :: ScopeIndex -> FreeScopeSummary -> FreeScopeSummary -> Either ScopeLookupFailure FreeScopeSummary +mergeFreeScopeSummary scopeIndex = + mergeFreeScopeSummaryByEither (scopeDepthOf scopeIndex) + +mergeFreeScopeSummaryBy :: (ScopeId -> Int) -> FreeScopeSummary -> FreeScopeSummary -> FreeScopeSummary +mergeFreeScopeSummaryBy depthOf leftSummary rightSummary = + either absurd id (mergeFreeScopeSummaryByEither (Right . depthOf) leftSummary rightSummary) + +mergeFreeScopeSummaryByEither :: + (ScopeId -> Either failure Int) -> + FreeScopeSummary -> + FreeScopeSummary -> + Either failure FreeScopeSummary +mergeFreeScopeSummaryByEither depthOf leftSummary rightSummary = + FreeScopeSummary . smallArrayFromList + <$> go (freeScopeSummaryToList leftSummary) (freeScopeSummaryToList rightSummary) + where + go leftValues rightValues = + case (leftValues, rightValues) of + ([], []) -> + Right [] + ([], _) -> + Right rightValues + (_, []) -> + Right leftValues + (leftScope : remainingLeft, rightScope : remainingRight) + | leftScope == rightScope -> + (leftScope :) <$> go remainingLeft remainingRight + | otherwise -> do + leftDepth <- depthOf leftScope + rightDepth <- depthOf rightScope + case compare leftDepth rightDepth of + GT -> + (leftScope :) <$> go remainingLeft rightValues + LT -> + (rightScope :) <$> go leftValues remainingRight + EQ -> + case compare leftScope rightScope of + LT -> + (leftScope :) <$> go remainingLeft rightValues + GT -> + (rightScope :) <$> go leftValues remainingRight + EQ -> + (leftScope :) <$> go remainingLeft remainingRight + +deleteFreeScopeSummary :: ScopeId -> FreeScopeSummary -> FreeScopeSummary +deleteFreeScopeSummary targetScope summaryValue = + FreeScopeSummary + ( smallArrayFromList + (filter (/= targetScope) (freeScopeSummaryToList summaryValue)) + ) + +freeScopeSummaryContains :: ScopeId -> FreeScopeSummary -> Bool +freeScopeSummaryContains targetScope summaryValue = + go 0 + where + FreeScopeSummary scopeArray = summaryValue + go indexValue + | indexValue >= sizeofSmallArray scopeArray = + False + | indexSmallArray scopeArray indexValue == targetScope = + True + | otherwise = + go (indexValue + 1) + +freeScopeSummarySize :: FreeScopeSummary -> Int +freeScopeSummarySize (FreeScopeSummary scopeArray) = + sizeofSmallArray scopeArray + +freeScopeSummaryToList :: FreeScopeSummary -> [ScopeId] +freeScopeSummaryToList (FreeScopeSummary scopeArray) = + scopeArrayToList scopeArray + +freeScopeSupportAnchor :: ScopeIndex -> FreeScopeSummary -> ScopeId +freeScopeSupportAnchor scopeIndex (FreeScopeSummary scopeArray) + | sizeofSmallArray scopeArray > 0 = + indexSmallArray scopeArray 0 + | otherwise = + siRoot scopeIndex + +type PreorderIndex :: Type +data PreorderIndex = PreorderIndex + { preorderDepth :: !(Vector Int), + preorderSubtreeEnd :: !(Vector Int), + preorderHasBranch :: !Bool, + preorderDeepest :: !ScopeId + } + +type OpenScope :: Type +data OpenScope = OpenScope + { openScopeKey :: !Int, + openScopeDepth :: !Int + } + +type PreorderBuild :: Type +data PreorderBuild = PreorderBuild + { pbOpenScopes :: ![OpenScope], + pbDepthsRev :: ![Int], + pbSubtreeEnds :: !(IntMap.IntMap Int), + pbChildCounts :: !(IntMap.IntMap Int), + pbHasBranch :: !Bool, + pbDeepest :: !(ScopeId, Int) + } + +buildPreorderIndex :: Vector Int -> Either ScopeIndexFailure PreorderIndex +buildPreorderIndex parentVector = do + finalBuild <- + foldM + appendPreorderScope + PreorderBuild + { pbOpenScopes = [OpenScope 0 0], + pbDepthsRev = [0], + pbSubtreeEnds = IntMap.empty, + pbChildCounts = IntMap.singleton 0 0, + pbHasBranch = False, + pbDeepest = (rootScopeId, 0) + } + (zip [1 ..] (drop 1 (V.toList parentVector))) + let scopeCount = V.length parentVector + subtreeEnds = + foldr + (\openScope -> IntMap.insert (openScopeKey openScope) scopeCount) + (pbSubtreeEnds finalBuild) + (pbOpenScopes finalBuild) + materializedEnds <- + V.fromList + <$> traverse + ( \scopeKey -> + maybe + (Left (ScopeSubtreeEndMissing (ScopeId scopeKey))) + Right + (IntMap.lookup scopeKey subtreeEnds) + ) + [0 .. scopeCount - 1] + pure + PreorderIndex + { preorderDepth = V.fromList (reverse (pbDepthsRev finalBuild)), + preorderSubtreeEnd = materializedEnds, + preorderHasBranch = pbHasBranch finalBuild, + preorderDeepest = fst (pbDeepest finalBuild) + } + +appendPreorderScope :: PreorderBuild -> (Int, Int) -> Either ScopeIndexFailure PreorderBuild +appendPreorderScope buildState (scopeKey, parentKey) = do + (closedScopes, parentDepth, remainingOpen) <- + closeScopesUntil parentKey (pbOpenScopes buildState) + let childCount = IntMap.findWithDefault 0 parentKey (pbChildCounts buildState) + 1 + scopeDepth = parentDepth + 1 + deepestValue = + if scopeDepth > snd (pbDeepest buildState) + then (ScopeId scopeKey, scopeDepth) + else pbDeepest buildState + pure + buildState + { pbOpenScopes = OpenScope scopeKey scopeDepth : remainingOpen, + pbDepthsRev = scopeDepth : pbDepthsRev buildState, + pbSubtreeEnds = + foldr + (`IntMap.insert` scopeKey) + (pbSubtreeEnds buildState) + closedScopes, + pbChildCounts = + IntMap.insert scopeKey 0 + (IntMap.insert parentKey childCount (pbChildCounts buildState)), + pbHasBranch = pbHasBranch buildState || childCount > 1, + pbDeepest = deepestValue + } + where + closeScopesUntil targetScope openScopes = + case break ((== targetScope) . openScopeKey) openScopes of + (_, []) -> + Left (ScopeParentNotPreorder (ScopeId scopeKey) parentKey) + (closedScopes, parentScope : survivingScopes) -> + Right + ( fmap openScopeKey closedScopes, + openScopeDepth parentScope, + parentScope : survivingScopes + ) + +buildLift :: Vector Int -> Either ScopeIndexFailure (Vector (Vector Int)) +buildLift parentVector = + V.fromList . reverse + <$> foldM appendLevel [parentVector] [1 .. levelCount - 1] + where + scopeCount = V.length parentVector + + levelCount = + max 1 (length (takeWhile (< scopeCount) (iterate (* 2) 1))) + + appendLevel :: [Vector Int] -> Int -> Either ScopeIndexFailure [Vector Int] + appendLevel levels _ = + case levels of + [] -> + Left (ScopeLiftMissing rootScopeId) + previousLevel : _ -> do + nextLevel <- traverse (nextAncestor previousLevel) previousLevel + Right (nextLevel : levels) + + nextAncestor :: Vector Int -> Int -> Either ScopeIndexFailure Int + nextAncestor previousLevel ancestorKey = + maybe + (Left (ScopeLiftMissing (ScopeId ancestorKey))) + Right + (previousLevel V.!? ancestorKey) + +liftAncestor :: ScopeIndex -> Int -> ScopeId -> Either ScopeLookupFailure ScopeId +liftAncestor scopeIndex liftIndex scopeId = + case siLift scopeIndex V.!? liftIndex of + Nothing -> + Left (ScopeLiftLevelOutsideIndex liftIndex (V.length (siLift scopeIndex))) + Just liftLevel -> + ScopeId <$> scopeVectorValue ScopeIdOutsideIndex scopeId liftLevel + +scopeVectorValue :: (ScopeId -> Int -> ScopeLookupFailure) -> ScopeId -> Vector value -> Either ScopeLookupFailure value +scopeVectorValue failure scopeId vectorValue = + maybe + (Left (failure scopeId (V.length vectorValue))) + Right + (vectorValue V.!? scopeIdKey scopeId) + +binderVectorValue :: BinderId -> Vector ScopeId -> Either ScopeLookupFailure ScopeId +binderVectorValue binderId vectorValue = + maybe + (Left (BinderIdOutsideIndex binderId (V.length vectorValue))) + Right + (vectorValue V.!? binderIdKey binderId) diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Syntax.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Syntax.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Expr/Syntax.hs @@ -0,0 +1,828 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} + +module Moonlight.Pale.Ghc.Expr.Syntax + ( HsVarRef (..), + BinderAnn (..), + HsOpaqueTag (..), + HsPatOpaqueTag (..), + HsRecPatFieldValue (..), + HsRecPatItem (..), + HsPatF (..), + patBinders, + traversePatBinders, + LetRecursion (..), + BindingComponent (..), + BindingComponentRecursion (..), + FixityAssociativity (..), + FixityDeclaration (..), + TypeSignature (..), + ExactIntegral, + exactIntegralSource, + exactIntegralNegative, + exactIntegralValue, + exactIntegralToInteger, + exactIntegralFromInteger, + ExactFractional, + exactFractionalSource, + exactFractionalNegative, + exactFractionalSignificand, + exactFractionalExponent, + exactFractionalBase, + exactFractionalToRational, + exactFractionalFromRational, + NormalizedLit (..), + normalizeHsLit, + NormalizedOverLit (..), + normalizeHsOverLit, + NormalizedFieldLabel (..), + normalizeFieldLabel, + NormalizedTypeText (..), + NormalizedArithSeq (..), + TupleBoxity (..), + TupleSlot (..), + SourceRegion (..), + SourceCharRange, + SourceEndConvention (..), + SourceRangeFailure (..), + sourceRegionFromSrcSpan, + sourceRegionFromRealSrcSpan, + sourceCharRangeStart, + sourceCharRangeEnd, + sourceCharRangeFromOffsets, + sourceRegionCharRange, + sourceRegionCharRangeWith, + sourceCharRangeRegion, + sourceCharRangeRegionWith, + sourceCharRangeText, + HsExprF (..), + HsStmtF (..), + HsGuardStmtF (..), + GuardedAltF (..), + Expr (..), + eraseExpr, + HsExprTag (..), + TagSignature (..), + tagSignatureFromTag, + tagSignatureMember, + ) +where + +import Data.Bits (bit, testBit, (.|.)) +import Data.ByteString (ByteString) +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty) +import Data.Word (Word64) +import GHC.Data.FastString (unpackFS) +import GHC.Hs (GhcPs, HsLit (..), HsOverLit (..), OverLitVal (..)) +import GHC.Types.FieldLabel + ( DuplicateRecordFields (..), + FieldLabel, + FieldSelectors (..), + flHasDuplicateRecordFields, + flHasFieldSelector, + flSelector, + ) +import GHC.Types.Name (nameOccName) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Name.Reader (RdrName, rdrNameOcc) +import GHC.Types.SourceText (FractionalExponentBase (..), FractionalLit (..), IntegralLit (..), SourceText (..)) +import GHC.Types.SrcLoc + ( RealSrcSpan, + SrcSpan (..), + srcSpanEndCol, + srcSpanEndLine, + srcSpanStartCol, + srcSpanStartLine, + ) +import Moonlight.Core (BinderId, HasConstructorTag (..), Pattern (..), ZipMatch (..), zipSameNodeShape) +import Moonlight.Pale.Ghc.Expr.Opaque (HsOpaqueTag (..), HsPatOpaqueTag (..)) +import Moonlight.Pale.Ghc.Expr.Scope (FreeScopeSummary, ScopeId) + +type HsVarRef :: Type +data HsVarRef + = GlobalName !RdrName + | LocalName !BinderAnn + deriving stock (Eq, Ord) + +type BinderAnn :: Type +data BinderAnn = BinderAnn + { baId :: !BinderId, + baName :: !RdrName + } + deriving stock (Eq, Ord) + +instance Show HsVarRef where + show = \case + GlobalName rdrName -> "GlobalName " <> occNameString (rdrNameOcc rdrName) + LocalName binderAnn -> "LocalName " <> show binderAnn + +instance Show BinderAnn where + show binderAnn = + "BinderAnn { baId = " <> show (baId binderAnn) <> ", baName = " <> occNameString (rdrNameOcc (baName binderAnn)) <> " }" + +type HsRecPatFieldValue :: Type +data HsRecPatFieldValue + = HsRecPatExplicit !HsPatF + | HsRecPatPun !BinderAnn + deriving stock (Eq, Ord) + +instance Show HsRecPatFieldValue where + show = \case + HsRecPatExplicit fieldPattern -> + "HsRecPatExplicit (" <> show fieldPattern <> ")" + HsRecPatPun binderAnn -> + "HsRecPatPun (" <> show binderAnn <> ")" + +type HsRecPatItem :: Type +data HsRecPatItem + = HsRecPatField !RdrName !HsRecPatFieldValue + | HsRecPatWildcard !SourceRegion ![BinderAnn] + deriving stock (Eq, Ord) + +instance Show HsRecPatItem where + show = \case + HsRecPatField fieldName fieldValue -> + "HsRecPatField " + <> occNameString (rdrNameOcc fieldName) + <> " (" + <> show fieldValue + <> ")" + HsRecPatWildcard wildcardRegion wildcardBinders -> + "HsRecPatWildcard " + <> show wildcardRegion + <> " " + <> show wildcardBinders + +type HsPatF :: Type +data HsPatF + = PVarP !BinderAnn + | PWildP + | PConP !RdrName ![HsPatF] + | PTupleP !TupleBoxity ![HsPatF] + | PListP ![HsPatF] + | PLitP !NormalizedLit + | POverLitP !NormalizedOverLit + | PAsP !BinderAnn !HsPatF + | PBangP !HsPatF + | PLazyP !HsPatF + | PParP !HsPatF + | PRecP !RdrName ![HsRecPatItem] + deriving stock (Eq, Ord) + +instance Show HsPatF where + show = \case + PVarP binderAnn -> "PVarP (" <> show binderAnn <> ")" + PWildP -> "PWildP" + PConP conName subPatterns -> "PConP " <> occNameString (rdrNameOcc conName) <> " " <> show subPatterns + PTupleP boxity subPatterns -> "PTupleP " <> show boxity <> " " <> show subPatterns + PListP subPatterns -> "PListP " <> show subPatterns + PLitP literalValue -> "PLitP (" <> show literalValue <> ")" + POverLitP literalValue -> "POverLitP (" <> show literalValue <> ")" + PAsP binderAnn subPattern -> "PAsP (" <> show binderAnn <> ") (" <> show subPattern <> ")" + PBangP subPattern -> "PBangP (" <> show subPattern <> ")" + PLazyP subPattern -> "PLazyP (" <> show subPattern <> ")" + PParP subPattern -> "PParP (" <> show subPattern <> ")" + PRecP conName recordItems -> "PRecP " <> occNameString (rdrNameOcc conName) <> " " <> show recordItems + +patBinders :: HsPatF -> [BinderAnn] +patBinders = \case + PVarP binderAnn -> [binderAnn] + PWildP -> [] + PConP _ subPatterns -> foldMap patBinders subPatterns + PTupleP _ subPatterns -> foldMap patBinders subPatterns + PListP subPatterns -> foldMap patBinders subPatterns + PLitP _ -> [] + POverLitP _ -> [] + PAsP binderAnn subPattern -> binderAnn : patBinders subPattern + PBangP subPattern -> patBinders subPattern + PLazyP subPattern -> patBinders subPattern + PParP subPattern -> patBinders subPattern + PRecP _ recordItems -> foldMap recordItemBinders recordItems + +traversePatBinders :: Applicative f => (BinderAnn -> f BinderAnn) -> HsPatF -> f HsPatF +traversePatBinders onBinder = go + where + go = \case + PVarP binderAnn -> PVarP <$> onBinder binderAnn + PWildP -> pure PWildP + PConP conName subPatterns -> PConP conName <$> traverse go subPatterns + PTupleP boxity subPatterns -> PTupleP boxity <$> traverse go subPatterns + PListP subPatterns -> PListP <$> traverse go subPatterns + PLitP literalValue -> pure (PLitP literalValue) + POverLitP literalValue -> pure (POverLitP literalValue) + PAsP binderAnn subPattern -> PAsP <$> onBinder binderAnn <*> go subPattern + PBangP subPattern -> PBangP <$> go subPattern + PLazyP subPattern -> PLazyP <$> go subPattern + PParP subPattern -> PParP <$> go subPattern + PRecP conName recordItems -> + PRecP conName <$> traverse (traverseRecordItemBinders onBinder) recordItems + +recordItemBinders :: HsRecPatItem -> [BinderAnn] +recordItemBinders = \case + HsRecPatField _ (HsRecPatExplicit fieldPattern) -> + patBinders fieldPattern + HsRecPatField _ (HsRecPatPun binderAnn) -> + [binderAnn] + HsRecPatWildcard _ wildcardBinders -> + wildcardBinders + +traverseRecordItemBinders :: + Applicative f => + (BinderAnn -> f BinderAnn) -> + HsRecPatItem -> + f HsRecPatItem +traverseRecordItemBinders onBinder = \case + HsRecPatField fieldName (HsRecPatExplicit fieldPattern) -> + HsRecPatField fieldName . HsRecPatExplicit + <$> traversePatBinders onBinder fieldPattern + HsRecPatField fieldName (HsRecPatPun binderAnn) -> + HsRecPatField fieldName . HsRecPatPun + <$> onBinder binderAnn + HsRecPatWildcard wildcardRegion wildcardBinders -> + HsRecPatWildcard wildcardRegion + <$> traverse onBinder wildcardBinders + +type LetRecursion :: Type +data LetRecursion + = NonRecursiveBinds + | AcyclicDependentBinds + | RecursiveBinds + deriving stock (Eq, Ord, Show) + +type BindingComponent :: Type +data BindingComponent = BindingComponent + { bindingComponentRows :: !(NonEmpty Int), + bindingComponentBinders :: ![BinderId], + bindingComponentDependencies :: ![BinderId], + bindingComponentRecursion :: !BindingComponentRecursion + } + deriving stock (Eq, Ord, Show) + +type BindingComponentRecursion :: Type +data BindingComponentRecursion + = AcyclicBindingComponent + | RecursiveBindingComponent + deriving stock (Eq, Ord, Show) + +type FixityAssociativity :: Type +data FixityAssociativity + = FixityLeft + | FixityRight + | FixityNone + deriving stock (Eq, Ord, Show) + +type FixityDeclaration :: Type +data FixityDeclaration = FixityDeclaration + { fixityAssociativity :: !FixityAssociativity, + fixityPrecedence :: !Int, + fixityOperators :: !(NonEmpty RdrName) + } + deriving stock (Eq, Ord) + +instance Show FixityDeclaration where + show declaration = + "FixityDeclaration " + <> show (fixityAssociativity declaration) + <> " " + <> show (fixityPrecedence declaration) + <> " " + <> show (fmap (occNameString . rdrNameOcc) (fixityOperators declaration)) + +type TypeSignature :: Type +data TypeSignature = TypeSignature + { typeSignatureNames :: !(NonEmpty RdrName), + typeSignatureType :: !NormalizedTypeText + } + deriving stock (Eq, Ord) + +instance Show TypeSignature where + show signature = + "TypeSignature " + <> show (fmap (occNameString . rdrNameOcc) (typeSignatureNames signature)) + <> " " + <> show (typeSignatureType signature) + +type NormalizedLit :: Type +data NormalizedLit + = NormalizedChar !Char + | NormalizedCharPrim !Char + | NormalizedString !String + | NormalizedMultilineString !String + | NormalizedStringPrim !ByteString + | NormalizedInt !ExactIntegral + | NormalizedIntPrim !ExactIntegral + | NormalizedWordPrim !ExactIntegral + | NormalizedInt8Prim !ExactIntegral + | NormalizedInt16Prim !ExactIntegral + | NormalizedInt32Prim !ExactIntegral + | NormalizedInt64Prim !ExactIntegral + | NormalizedWord8Prim !ExactIntegral + | NormalizedWord16Prim !ExactIntegral + | NormalizedWord32Prim !ExactIntegral + | NormalizedWord64Prim !ExactIntegral + | NormalizedFloatPrim !ExactFractional + | NormalizedDoublePrim !ExactFractional + deriving stock (Eq, Ord, Show) + +type NormalizedOverLit :: Type +data NormalizedOverLit + = NormalizedIntegralOverLit !ExactIntegral + | NormalizedFractionalOverLit !ExactFractional + | NormalizedStringOverLit !String + deriving stock (Eq, Ord, Show) + +type NormalizedTypeText :: Type +newtype NormalizedTypeText = NormalizedTypeText + { nttText :: String + } + deriving stock (Eq, Ord, Show) + +type NormalizedFieldLabel :: Type +data NormalizedFieldLabel = NormalizedFieldLabel + { nflSelector :: !String, + nflAllowsDuplicateRecordFields :: !Bool, + nflHasSelector :: !Bool + } + deriving stock (Eq, Ord, Show) + +type NormalizedArithSeq :: Type -> Type +data NormalizedArithSeq r + = ArithSeqFrom !r + | ArithSeqFromThen !r !r + | ArithSeqFromTo !r !r + | ArithSeqFromThenTo !r !r !r + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + +type ExactIntegral :: Type +data ExactIntegral = ExactIntegral + { exactIntegralSource :: !(Maybe String), + exactIntegralNegative :: !Bool, + exactIntegralValue :: !Integer + } + deriving stock (Eq, Ord, Show) + +type ExactFractional :: Type +data ExactFractional = ExactFractional + { exactFractionalSource :: !(Maybe String), + exactFractionalNegative :: !Bool, + exactFractionalSignificand :: !Rational, + exactFractionalExponent :: !Integer, + exactFractionalBase :: !FractionalExponentBase + } + deriving stock (Eq, Ord, Show) + +exactIntegralToInteger :: ExactIntegral -> Integer +exactIntegralToInteger exactValue = + (if exactIntegralNegative exactValue then negate else id) + (exactIntegralValue exactValue) + +exactIntegralFromInteger :: Integer -> ExactIntegral +exactIntegralFromInteger value = + ExactIntegral + { exactIntegralSource = Nothing, + exactIntegralNegative = value < 0, + exactIntegralValue = abs value + } + +exactFractionalToRational :: ExactFractional -> Rational +exactFractionalToRational exactValue = + let exponentFactor = + case exactFractionalBase exactValue of + Base10 -> rationalPower 10 (exactFractionalExponent exactValue) + Base2 -> rationalPower 2 (exactFractionalExponent exactValue) + unsignedValue = + exactFractionalSignificand exactValue * exponentFactor + in (if exactFractionalNegative exactValue then negate else id) unsignedValue + +exactFractionalFromRational :: Rational -> ExactFractional +exactFractionalFromRational value = + ExactFractional + { exactFractionalSource = Nothing, + exactFractionalNegative = value < 0, + exactFractionalSignificand = abs value, + exactFractionalExponent = 0, + exactFractionalBase = Base10 + } + +rationalPower :: Integer -> Integer -> Rational +rationalPower baseValue exponentValue + | exponentValue < 0 = + 1 / fromInteger (baseValue ^ negate exponentValue) + | otherwise = + fromInteger (baseValue ^ exponentValue) + +type TupleSlot :: Type -> Type +data TupleSlot r + = TuplePresent !r + | TupleMissing + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + +type TupleBoxity :: Type +data TupleBoxity + = BoxedTuple + | UnboxedTuple + deriving stock (Eq, Ord, Show) + +type SourceRegion :: Type +data SourceRegion = SourceRegion + { srStartLine :: !Int, + srStartCol :: !Int, + srEndLine :: !Int, + srEndCol :: !Int + } + deriving stock (Eq, Ord, Show) + +type SourceCharRange :: Type +data SourceCharRange = SourceCharRange + { sourceCharRangeStart :: !Int, + sourceCharRangeEnd :: !Int + } + deriving stock (Eq, Ord, Show) + +type SourceEndConvention :: Type +data SourceEndConvention + = SourceEndHalfOpen + | SourceEndInclusive + deriving stock (Eq, Ord, Show) + +type SourceRangeFailure :: Type +data SourceRangeFailure + = SourceRangePositionOutsideSource !Int !Int + | SourceRangePositionInsideTab !Int !Int + | SourceRangeEndsBeforeStart !SourceRegion + | SourceRangeOffsetsInvalid !Int !Int + | SourceRangeInvalidTabStop !Int + | SourceRangeCarriageReturnUnsupported + deriving stock (Eq, Ord, Show) + +sourceRegionFromSrcSpan :: SrcSpan -> Maybe SourceRegion +sourceRegionFromSrcSpan = \case + RealSrcSpan realSpan _ -> + Just (sourceRegionFromRealSrcSpan realSpan) + UnhelpfulSpan _ -> + Nothing + +sourceRegionFromRealSrcSpan :: RealSrcSpan -> SourceRegion +sourceRegionFromRealSrcSpan realSpan = + SourceRegion + { srStartLine = srcSpanStartLine realSpan, + srStartCol = srcSpanStartCol realSpan, + srEndLine = srcSpanEndLine realSpan, + srEndCol = srcSpanEndCol realSpan + } + +sourceCharRangeFromOffsets :: Int -> Int -> Either SourceRangeFailure SourceCharRange +sourceCharRangeFromOffsets startOffset endOffset + | startOffset < 0 || endOffset < startOffset = + Left (SourceRangeOffsetsInvalid startOffset endOffset) + | otherwise = + Right (SourceCharRange startOffset endOffset) + +sourceRegionCharRange :: String -> SourceRegion -> Either SourceRangeFailure SourceCharRange +sourceRegionCharRange = sourceRegionCharRangeWith 8 SourceEndHalfOpen + +sourceRegionCharRangeWith :: Int -> SourceEndConvention -> String -> SourceRegion -> Either SourceRangeFailure SourceCharRange +sourceRegionCharRangeWith tabStop endConvention source region = do + if tabStop > 0 + then Right () + else Left (SourceRangeInvalidTabStop tabStop) + if '\r' `elem` source + then Left SourceRangeCarriageReturnUnsupported + else Right () + startOffset <- sourcePositionOffset tabStop source (srStartLine region) (srStartCol region) + endOffset <- + case endConvention of + SourceEndHalfOpen -> sourcePositionOffset tabStop source (srEndLine region) (srEndCol region) + SourceEndInclusive -> sourceInclusivePositionEndOffset tabStop source (srEndLine region) (srEndCol region) + if startOffset <= endOffset + then Right (SourceCharRange startOffset endOffset) + else Left (SourceRangeEndsBeforeStart region) + +sourceCharRangeRegion :: String -> SourceCharRange -> Either SourceRangeFailure SourceRegion +sourceCharRangeRegion = sourceCharRangeRegionWith 8 + +sourceCharRangeRegionWith :: Int -> String -> SourceCharRange -> Either SourceRangeFailure SourceRegion +sourceCharRangeRegionWith tabStop source sourceRange@(SourceCharRange startOffset endOffset) = do + if tabStop > 0 + then Right () + else Left (SourceRangeInvalidTabStop tabStop) + if '\r' `elem` source + then Left SourceRangeCarriageReturnUnsupported + else Right () + _ <- sourceCharRangeText source sourceRange + (startLine, startColumn) <- sourcePositionAtOffset tabStop source startOffset + (endLine, endColumn) <- sourcePositionAtOffset tabStop source endOffset + Right + SourceRegion + { srStartLine = startLine, + srStartCol = startColumn, + srEndLine = endLine, + srEndCol = endColumn + } + +sourceCharRangeText :: String -> SourceCharRange -> Either SourceRangeFailure String +sourceCharRangeText source (SourceCharRange startOffset endOffset) + | startOffset >= 0 && startOffset <= endOffset && endOffset <= length source = + Right (take (endOffset - startOffset) (drop startOffset source)) + | otherwise = + Left (SourceRangeOffsetsInvalid startOffset endOffset) + +sourcePositionOffset :: Int -> String -> Int -> Int -> Either SourceRangeFailure Int +sourcePositionOffset tabStop source lineNumber columnNumber = do + (lineStart, lineText) <- sourceLineAt source lineNumber columnNumber + localOffset <- sourceLineBoundaryOffset tabStop lineNumber columnNumber lineText + Right (lineStart + localOffset) + +sourceInclusivePositionEndOffset :: Int -> String -> Int -> Int -> Either SourceRangeFailure Int +sourceInclusivePositionEndOffset tabStop source lineNumber columnNumber = do + (lineStart, lineText) <- sourceLineAt source lineNumber columnNumber + localOffset <- sourceLineBoundaryOffset tabStop lineNumber columnNumber lineText + if localOffset < length lineText + then Right (lineStart + localOffset + 1) + else Left (SourceRangePositionOutsideSource lineNumber columnNumber) + +sourceLineAt :: String -> Int -> Int -> Either SourceRangeFailure (Int, String) +sourceLineAt source lineNumber columnNumber = + case drop (lineNumber - 1) (sourceLineRows source) of + lineRow : _ + | lineNumber >= 1 && columnNumber >= 1 -> Right lineRow + _ -> Left (SourceRangePositionOutsideSource lineNumber columnNumber) + +sourceLineRows :: String -> [(Int, String)] +sourceLineRows source = + let lineTexts = splitCanonicalLines source + lineStarts = scanl (\lineStart lineText -> lineStart + length lineText + 1) 0 lineTexts + in zip lineStarts lineTexts + +sourcePositionAtOffset :: Int -> String -> Int -> Either SourceRangeFailure (Int, Int) +sourcePositionAtOffset tabStop source sourceOffset = + case containingLine of + Nothing -> Left (SourceRangeOffsetsInvalid sourceOffset sourceOffset) + Just (lineNumber, lineStart, lineText) -> + let localOffset = sourceOffset - lineStart + visualColumn = foldl (advanceVisualColumn tabStop) 1 (take localOffset lineText) + in if localOffset <= length lineText + then Right (lineNumber, visualColumn) + else Left (SourceRangeOffsetsInvalid sourceOffset sourceOffset) + where + containingLine = + foldl + (\selected row -> if lineStartOf row <= sourceOffset then Just row else selected) + Nothing + (zipWith toNumberedLine [1 ..] (sourceLineRows source)) + toNumberedLine :: Int -> (Int, String) -> (Int, Int, String) + toNumberedLine lineNumber (lineStart, lineText) = (lineNumber, lineStart, lineText) + lineStartOf :: (Int, Int, String) -> Int + lineStartOf (_, lineStart, _) = lineStart + +splitCanonicalLines :: String -> [String] +splitCanonicalLines source = + case break (== '\n') source of + (lineText, []) -> [lineText] + (lineText, _ : remaining) -> lineText : splitCanonicalLines remaining + +sourceLineBoundaryOffset :: Int -> Int -> Int -> String -> Either SourceRangeFailure Int +sourceLineBoundaryOffset tabStop lineNumber targetColumn = resolve 0 1 + where + resolve localOffset visualColumn remaining + | targetColumn == visualColumn = Right localOffset + | otherwise = + case remaining of + [] -> Left (SourceRangePositionOutsideSource lineNumber targetColumn) + character : rest -> + let nextVisualColumn = advanceVisualColumn tabStop visualColumn character + in if targetColumn > visualColumn && targetColumn < nextVisualColumn + then Left (SourceRangePositionInsideTab lineNumber targetColumn) + else resolve (localOffset + 1) nextVisualColumn rest + +advanceVisualColumn :: Int -> Int -> Char -> Int +advanceVisualColumn tabStop visualColumn character + | character == '\t' = ((visualColumn - 1) `div` tabStop + 1) * tabStop + 1 + | otherwise = visualColumn + 1 + +type HsExprF :: Type -> Type +data HsExprF r + = VarF !HsVarRef + | AppF !r !r + | LamF !BinderAnn !r + | LetF !LetRecursion ![(HsPatF, r)] !r + | OpChainF !r !(NonEmpty (r, r)) + | SectionLF !r !r + | SectionRF !r !r + | ParF !r + | LitF !NormalizedLit + | OverLitF !NormalizedOverLit + | IfF !r !r !r + | CaseF !r ![(HsPatF, r)] + | DoF ![HsStmtF r] + | NegF !r + | ExplicitListF ![r] + | ExplicitTupleF !TupleBoxity ![TupleSlot r] + | RecordConF !r ![(NormalizedFieldLabel, r)] + | RecordUpdF !r ![(NormalizedFieldLabel, r)] + | ArithSeqF !(NormalizedArithSeq r) + | GuardedF ![GuardedAltF r] + | ClausesF ![([HsPatF], r)] + | MultiIfF ![GuardedAltF r] + | ExprWithTySigF !r !NormalizedTypeText + | AppTypeF !r !NormalizedTypeText + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + +type HsGuardStmtF :: Type -> Type +data HsGuardStmtF r + = GuardBoolF !r + | GuardPatF !HsPatF !r + | GuardLetF !LetRecursion ![(HsPatF, r)] + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + +type GuardedAltF :: Type -> Type +data GuardedAltF r = GuardedAltF + { gaGuards :: ![HsGuardStmtF r], + gaBody :: !r + } + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + +type HsStmtF :: Type -> Type +data HsStmtF r + = BindStmtF !HsPatF !r + | BodyStmtF !r + | LetStmtF !LetRecursion ![(HsPatF, r)] + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + +type Expr :: Type +data Expr = Expr + { exprRegion :: !(Maybe SourceRegion), + exprScope :: !ScopeId, + exprFreeScopes :: !FreeScopeSummary, + exprNode :: !(HsExprF Expr) + } + deriving stock (Eq, Ord, Show) + +type HsExprTag :: Type +data HsExprTag + = VarTag + | AppTag + | LamTag + | LetTag + | OpChainTag + | SectionLTag + | SectionRTag + | ParTag + | LitTag + | OverLitTag + | IfTag + | CaseTag + | DoTag + | NegTag + | ExplicitListTag + | ExplicitTupleTag + | RecordConTag + | RecordUpdTag + | ArithSeqTag + | GuardedTag + | ClausesTag + | MultiIfTag + | ExprWithTySigTag + | AppTypeTag + deriving stock (Eq, Ord, Show, Enum, Bounded) + +type TagSignature :: Type +newtype TagSignature = TagSignature Word64 + deriving stock (Eq, Ord, Show) + +tagSignatureFromTag :: HsExprTag -> TagSignature +tagSignatureFromTag tag = + TagSignature (bit (fromEnum tag)) + +tagSignatureMember :: HsExprTag -> TagSignature -> Bool +tagSignatureMember tag (TagSignature signature) = + testBit signature (fromEnum tag) + +instance Semigroup TagSignature where + TagSignature left <> TagSignature right = + TagSignature (left .|. right) + +instance Monoid TagSignature where + mempty = + TagSignature 0 + +instance HasConstructorTag HsExprF where + type ConstructorTag HsExprF = HsExprTag + + constructorTag = \case + VarF {} -> VarTag + AppF {} -> AppTag + LamF {} -> LamTag + LetF {} -> LetTag + OpChainF {} -> OpChainTag + SectionLF {} -> SectionLTag + SectionRF {} -> SectionRTag + ParF {} -> ParTag + LitF {} -> LitTag + OverLitF {} -> OverLitTag + IfF {} -> IfTag + CaseF {} -> CaseTag + DoF {} -> DoTag + NegF {} -> NegTag + ExplicitListF {} -> ExplicitListTag + ExplicitTupleF {} -> ExplicitTupleTag + RecordConF {} -> RecordConTag + RecordUpdF {} -> RecordUpdTag + ArithSeqF {} -> ArithSeqTag + GuardedF {} -> GuardedTag + ClausesF {} -> ClausesTag + MultiIfF {} -> MultiIfTag + ExprWithTySigF {} -> ExprWithTySigTag + AppTypeF {} -> AppTypeTag + +instance ZipMatch HsExprF where + zipMatch = + zipSameNodeShape + +normalizeHsLit :: HsLit GhcPs -> NormalizedLit +normalizeHsLit = \case + HsChar _ value -> NormalizedChar value + HsCharPrim _ value -> NormalizedCharPrim value + HsString _ value -> NormalizedString (unpackFS value) + HsMultilineString _ value -> NormalizedMultilineString (unpackFS value) + HsStringPrim _ value -> NormalizedStringPrim value + HsInt _ value -> NormalizedInt (exactIntegral value) + HsIntPrim sourceText value -> NormalizedIntPrim (primitiveIntegral sourceText value) + HsWordPrim sourceText value -> NormalizedWordPrim (primitiveIntegral sourceText value) + HsInt8Prim sourceText value -> NormalizedInt8Prim (primitiveIntegral sourceText value) + HsInt16Prim sourceText value -> NormalizedInt16Prim (primitiveIntegral sourceText value) + HsInt32Prim sourceText value -> NormalizedInt32Prim (primitiveIntegral sourceText value) + HsInt64Prim sourceText value -> NormalizedInt64Prim (primitiveIntegral sourceText value) + HsWord8Prim sourceText value -> NormalizedWord8Prim (primitiveIntegral sourceText value) + HsWord16Prim sourceText value -> NormalizedWord16Prim (primitiveIntegral sourceText value) + HsWord32Prim sourceText value -> NormalizedWord32Prim (primitiveIntegral sourceText value) + HsWord64Prim sourceText value -> NormalizedWord64Prim (primitiveIntegral sourceText value) + HsFloatPrim _ value -> NormalizedFloatPrim (exactFractional value) + HsDoublePrim _ value -> NormalizedDoublePrim (exactFractional value) + +normalizeHsOverLit :: HsOverLit GhcPs -> NormalizedOverLit +normalizeHsOverLit = \case + OverLit {ol_val = value} -> normalizeOverLitVal value + +normalizeFieldLabel :: FieldLabel -> NormalizedFieldLabel +normalizeFieldLabel fieldLabelValue = + NormalizedFieldLabel + { nflSelector = occNameString (nameOccName (flSelector fieldLabelValue)), + nflAllowsDuplicateRecordFields = duplicateFieldFlag (flHasDuplicateRecordFields fieldLabelValue), + nflHasSelector = selectorFieldFlag (flHasFieldSelector fieldLabelValue) + } + +eraseExpr :: Expr -> Pattern HsExprF +eraseExpr expressionValue = + PatternNode (fmap eraseExpr (exprNode expressionValue)) + +normalizeOverLitVal :: OverLitVal -> NormalizedOverLit +normalizeOverLitVal = \case + HsIntegral value -> NormalizedIntegralOverLit (exactIntegral value) + HsFractional value -> NormalizedFractionalOverLit (exactFractional value) + HsIsString _ value -> NormalizedStringOverLit (unpackFS value) + +exactIntegral :: IntegralLit -> ExactIntegral +exactIntegral (IL sourceText isNegative value) = + ExactIntegral + { exactIntegralSource = sourceTextString sourceText, + exactIntegralNegative = isNegative, + exactIntegralValue = value + } + +primitiveIntegral :: SourceText -> Integer -> ExactIntegral +primitiveIntegral sourceText value = + ExactIntegral + { exactIntegralSource = sourceTextString sourceText, + exactIntegralNegative = value < 0, + exactIntegralValue = abs value + } + +exactFractional :: FractionalLit -> ExactFractional +exactFractional fractionalLit = + ExactFractional + { exactFractionalSource = sourceTextString (fl_text fractionalLit), + exactFractionalNegative = fl_neg fractionalLit, + exactFractionalSignificand = fl_signi fractionalLit, + exactFractionalExponent = fl_exp fractionalLit, + exactFractionalBase = fl_exp_base fractionalLit + } + +sourceTextString :: SourceText -> Maybe String +sourceTextString = \case + SourceText sourceText -> Just (unpackFS sourceText) + NoSourceText -> Nothing + +duplicateFieldFlag :: DuplicateRecordFields -> Bool +duplicateFieldFlag = \case + DuplicateRecordFields -> True + NoDuplicateRecordFields -> False + +selectorFieldFlag :: FieldSelectors -> Bool +selectorFieldFlag = \case + FieldSelectors -> True + NoFieldSelectors -> False diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Hie/Oracle.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Hie/Oracle.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Hie/Oracle.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE StandaloneKindSignatures #-} + +{-| Package-origin and occurrence-resolution oracle values. -} +module Moonlight.Pale.Ghc.Hie.Oracle + ( PackageName, + PackageVersion, + PackageUnit, + PackageUnitParseFailure (..), + mkPackageUnit, + packageUnitText, + mkResolvedOrigin, + ResolvedOrigin (..), + ModuleNameOracle (..), + occResolvesUniquely, + originAcceptedBy, + ) +where + +import Data.Char (isDigit) +import Data.Kind (Type) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Moonlight.Pale.Ghc.Expr (SourceRegion) +import Moonlight.Pale.Ghc.Hie.TypeWords (TypeWords) + +type PackageName :: Type +newtype PackageName = PackageName String + deriving stock (Eq, Ord, Show) + +type PackageVersion :: Type +newtype PackageVersion = PackageVersion String + deriving stock (Eq, Ord, Show) + +type PackageUnit :: Type +data PackageUnit = PackageUnit + { puName :: !PackageName, + puVersion :: !(Maybe PackageVersion), + puText :: !String + } + deriving stock (Eq, Ord, Show) + +type PackageUnitParseFailure :: Type +data PackageUnitParseFailure + = EmptyPackageUnit + | EmptyPackageName !String + deriving stock (Eq, Ord, Show) + +type ResolvedOrigin :: Type +data ResolvedOrigin = ResolvedOrigin + { roUnit :: !PackageUnit, + roModule :: !String, + roOcc :: !String + } + deriving stock (Eq, Ord, Show) + +type ModuleNameOracle :: Type +data ModuleNameOracle = ModuleNameOracle + { mnoSourcePath :: !FilePath, + mnoGlobalUsesAtSpan :: !(Map SourceRegion (Map String (Set ResolvedOrigin))), + mnoGlobalUses :: !(Map String (Set ResolvedOrigin)), + mnoEvidenceAtSpan :: !(Map SourceRegion (Set ResolvedOrigin)), + mnoTypeAtSpan :: !(Map SourceRegion (Set TypeWords)) + } + deriving stock (Eq, Show) + +occResolvesUniquely :: ModuleNameOracle -> String -> Set ResolvedOrigin -> Bool +occResolvesUniquely oracle occName acceptedOrigins = + case Map.lookup occName (mnoGlobalUses oracle) of + Nothing -> + False + Just resolvedOrigins -> + Set.size resolvedOrigins == 1 + && Set.isSubsetOf resolvedOrigins acceptedOrigins + +originAcceptedBy :: ResolvedOrigin -> Set ResolvedOrigin -> Bool +originAcceptedBy = + Set.member + +mkResolvedOrigin :: String -> String -> String -> Either PackageUnitParseFailure ResolvedOrigin +mkResolvedOrigin unitText moduleText occText = + (\unitValue -> ResolvedOrigin unitValue moduleText occText) <$> mkPackageUnit unitText + +mkPackageUnit :: String -> Either PackageUnitParseFailure PackageUnit +mkPackageUnit unitText + | null unitText = + Left EmptyPackageUnit + | otherwise = + case packageUnitParts unitText of + ("", _) -> + Left (EmptyPackageName unitText) + (nameText, versionText) -> + Right + PackageUnit + { puName = PackageName nameText, + puVersion = fmap PackageVersion versionText, + puText = unitText + } + +packageUnitText :: PackageUnit -> String +packageUnitText = + puText + +packageUnitParts :: String -> (String, Maybe String) +packageUnitParts unitText = + case break (== '-') (reverse unitText) of + (reversedSuffix, '-' : reversedName) + | let suffixText = reverse reversedSuffix, + versionLike suffixText -> + (reverse reversedName, Just suffixText) + _ -> + (unitText, Nothing) + +versionLike :: String -> Bool +versionLike textValue = + case textValue of + [] -> + False + firstChar : _ -> + isDigit firstChar && all versionChar textValue + +versionChar :: Char -> Bool +versionChar charValue = + isDigit charValue || charValue == '.' diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Hie/Read.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Hie/Read.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Hie/Read.hs @@ -0,0 +1,453 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +{-| Reading HIE files into module-name oracle indexes. -} +module Moonlight.Pale.Ghc.Hie.Read + ( HieReadError (..), + readModuleOracle, + hieFileOracle, + indexHieRoots, + ) +where + +import Control.Exception (SomeAsyncException, SomeException, fromException, throwIO, try) +import Data.Array (Array) +import Data.Bifunctor (first) +import Data.Either (partitionEithers) +import Data.Foldable (foldlM) +import Data.Kind (Type) +import Data.List (isPrefixOf, sort) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import GHC.Iface.Ext.Binary (HieFileResult (..), readHieFile) +import GHC.Iface.Ext.Types + ( ContextInfo (..), + HieAST (..), + HieASTs (..), + HieFile (..), + HieTypeFlat, + Identifier, + IdentifierDetails (..), + NodeInfo (..), + SourcedNodeInfo (..), + TypeIndex, + ) +import GHC.Types.Name (Name, isExternalName, nameModule, nameOccName) +import GHC.Types.Name.Cache (NameCache, newNameCache) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Unit.Module (moduleName, moduleNameString, moduleUnit, unitString) +import Moonlight.Pale.Ghc.Hie.Oracle (ModuleNameOracle (..), ResolvedOrigin (..), mkPackageUnit) +import Moonlight.Pale.Ghc.Hie.SourceKey + ( HieOracleArtifact (..), + HieOracleIndex, + buildHieOracleIndex, + ) +import Moonlight.Pale.Ghc.Hie.TypeWords + ( TypeGraphObstruction (..), + TypeWords, + hieTypeRootsTypeWords, + ) +import Moonlight.Pale.Ghc.Expr (SourceRegion, sourceRegionFromRealSrcSpan) +import System.Directory + ( canonicalizePath, + doesDirectoryExist, + doesFileExist, + listDirectory, + pathIsSymbolicLink, + ) +import System.FilePath (normalise, takeExtension, ()) + +type HieReadError :: Type +data HieReadError + = HieReadError !FilePath !String + | HieRootError !FilePath !String + | HieTraversalError !FilePath !String + | HieTypeGraphError !FilePath !(Map SourceRegion (Set.Set TypeGraphObstruction)) + deriving stock (Eq, Show) + +readModuleOracle :: NameCache -> FilePath -> IO (Either HieReadError ModuleNameOracle) +readModuleOracle nameCache hiePath = do + readResult <- tryReadHieFile nameCache hiePath + pure + ( first (HieReadError hiePath . show) readResult + >>= hieFileOracle hiePath + ) + +indexHieRoots :: [FilePath] -> IO ([HieReadError], HieOracleIndex) +indexHieRoots [] = + pure ([], buildHieOracleIndex []) +indexHieRoots roots = do + nameCache <- newNameCache + collection <- collectHieRoots roots + readResults <- + traverse + ( \hiePath -> + fmap (HieOracleArtifact hiePath) + <$> readModuleOracle nameCache hiePath + ) + (Set.toAscList (hcFiles collection)) + let (readErrors, artifacts) = + partitionEithers readResults + pure + ( reverse (hcErrorsReversed collection) <> readErrors, + buildHieOracleIndex artifacts + ) + +tryReadHieFile :: NameCache -> FilePath -> IO (Either SomeException HieFileResult) +tryReadHieFile nameCache hiePath = + trySynchronousException (readHieFile nameCache hiePath) + +hieFileOracle :: FilePath -> HieFileResult -> Either HieReadError ModuleNameOracle +hieFileOracle hiePath result = + let hieFile = hie_file_result result + oracleBuild = foldHieAsts (hie_asts hieFile) + typeProjection = projectTypeRoots (hie_types hieFile) (obTypeRoots oracleBuild) + in if Map.null (tpObstructions typeProjection) + then + Right + ModuleNameOracle + { mnoSourcePath = normalise (hie_hs_file hieFile), + mnoGlobalUsesAtSpan = obGlobalUsesAtSpan oracleBuild, + mnoGlobalUses = obGlobals oracleBuild, + mnoEvidenceAtSpan = obEvidence oracleBuild, + mnoTypeAtSpan = tpWords typeProjection + } + else + Left (HieTypeGraphError hiePath (tpObstructions typeProjection)) + +data OracleBuild = OracleBuild + { obGlobals :: !(Map String (Set.Set ResolvedOrigin)), + obGlobalUsesAtSpan :: !(Map SourceRegion (Map String (Set.Set ResolvedOrigin))), + obEvidence :: !(Map SourceRegion (Set.Set ResolvedOrigin)), + obTypeRoots :: !(Map SourceRegion (Set.Set TypeIndex)) + } + +emptyOracleBuild :: OracleBuild +emptyOracleBuild = + OracleBuild + { obGlobals = Map.empty, + obGlobalUsesAtSpan = Map.empty, + obEvidence = Map.empty, + obTypeRoots = Map.empty + } + +foldHieAsts :: HieASTs TypeIndex -> OracleBuild +foldHieAsts (HieASTs astsByPath) = + Map.foldl' foldHieAst emptyOracleBuild astsByPath + +foldHieAst :: OracleBuild -> HieAST TypeIndex -> OracleBuild +foldHieAst oracleBuild ast = + foldl' + foldHieAst + ( Map.foldl' + (foldNodeInfo (sourceRegionFromRealSrcSpan (nodeSpan ast))) + oracleBuild + (getSourcedNodeInfo (sourcedNodeInfo ast)) + ) + (nodeChildren ast) + +foldNodeInfo :: SourceRegion -> OracleBuild -> NodeInfo TypeIndex -> OracleBuild +foldNodeInfo region oracleBuild nodeInfo = + Map.foldlWithKey' + (foldIdentifierDetails region) + ( foldl' + (\buildValue typeIndex -> buildValue {obTypeRoots = insertAt region typeIndex (obTypeRoots buildValue)}) + oracleBuild + (nodeType nodeInfo) + ) + (nodeIdentifiers nodeInfo) + +foldIdentifierDetails :: SourceRegion -> OracleBuild -> Identifier -> IdentifierDetails TypeIndex -> OracleBuild +foldIdentifierDetails region oracleBuild identifier details = + maybe + oracleBuild + ( \origin -> + OracleBuild + { obGlobals = + if Set.member Use (identInfo details) + then insertAt (roOcc origin) origin (obGlobals oracleBuild) + else obGlobals oracleBuild, + obGlobalUsesAtSpan = + if Set.member Use (identInfo details) + then insertGlobalUseAtSpan region origin (obGlobalUsesAtSpan oracleBuild) + else obGlobalUsesAtSpan oracleBuild, + obEvidence = + if any evidenceContext (identInfo details) + then insertAt region origin (obEvidence oracleBuild) + else obEvidence oracleBuild, + obTypeRoots = obTypeRoots oracleBuild + } + ) + (identifierOrigin identifier) + +insertAt :: (Ord key, Ord value) => key -> value -> Map key (Set.Set value) -> Map key (Set.Set value) +insertAt key value = + Map.insertWith Set.union key (Set.singleton value) + +insertGlobalUseAtSpan :: SourceRegion -> ResolvedOrigin -> Map SourceRegion (Map String (Set.Set ResolvedOrigin)) -> Map SourceRegion (Map String (Set.Set ResolvedOrigin)) +insertGlobalUseAtSpan region origin = + Map.insertWith + (Map.unionWith Set.union) + region + (Map.singleton (roOcc origin) (Set.singleton origin)) + +evidenceContext :: ContextInfo -> Bool +evidenceContext = \case + EvidenceVarBind {} -> + True + EvidenceVarUse -> + True + _ -> + False + +data TypeProjection = TypeProjection + { tpWords :: !(Map SourceRegion (Set.Set TypeWords)), + tpObstructions :: !(Map SourceRegion (Set.Set TypeGraphObstruction)) + } + +projectTypeRoots :: + Array TypeIndex HieTypeFlat -> + Map SourceRegion (Set.Set TypeIndex) -> + TypeProjection +projectTypeRoots typeTable rootsByRegion = + let regionsByRoot = regionsByTypeRoot rootsByRegion + compiledRoots = hieTypeRootsTypeWords typeTable (Map.keysSet regionsByRoot) + in Map.foldlWithKey' + (projectRoot compiledRoots) + TypeProjection {tpWords = Map.empty, tpObstructions = Map.empty} + regionsByRoot + where + projectRoot compiledRoots projection typeIndex regions = + case Map.findWithDefault (Left (MissingTypeIndex typeIndex)) typeIndex compiledRoots of + Left obstruction -> + projection + { tpObstructions = + insertAcrossRegions obstruction regions (tpObstructions projection) + } + Right wordsValue -> + projection + { tpWords = + insertAcrossRegions wordsValue regions (tpWords projection) + } + +regionsByTypeRoot :: Map SourceRegion (Set.Set TypeIndex) -> Map TypeIndex (Set.Set SourceRegion) +regionsByTypeRoot = + Map.foldlWithKey' + ( \rootsByIndex region typeIndices -> + Set.foldl' + (\nextRoots typeIndex -> insertAt typeIndex region nextRoots) + rootsByIndex + typeIndices + ) + Map.empty + +insertAcrossRegions :: + (Ord value) => + value -> + Set.Set SourceRegion -> + Map SourceRegion (Set.Set value) -> + Map SourceRegion (Set.Set value) +insertAcrossRegions value regions valuesByRegion = + Set.foldl' + (\nextValues region -> insertAt region value nextValues) + valuesByRegion + regions + +identifierOrigin :: Identifier -> Maybe ResolvedOrigin +identifierOrigin = \case + Left _ -> + Nothing + Right name -> + nameOrigin name + +nameOrigin :: Name -> Maybe ResolvedOrigin +nameOrigin name = + if isExternalName name + then + let nameModuleValue = nameModule name + unitText = unitString (moduleUnit nameModuleValue) + in case mkPackageUnit unitText of + Left _ -> + Nothing + Right unitValue -> + Just + ResolvedOrigin + { roUnit = unitValue, + roModule = moduleNameString (moduleName nameModuleValue), + roOcc = occNameString (nameOccName name) + } + else Nothing + +data HieCollection = HieCollection + { hcVisitedDirectories :: !(Set.Set FilePath), + hcFiles :: !(Set.Set FilePath), + hcErrorsReversed :: ![HieReadError] + } + +emptyHieCollection :: HieCollection +emptyHieCollection = + HieCollection + { hcVisitedDirectories = Set.empty, + hcFiles = Set.empty, + hcErrorsReversed = [] + } + +data TraversalContext + = RootContext + | DescendantContext + +data PathKind + = DirectoryPath + | DirectorySymlinkPath + | FilePathKind + | MissingPath + +collectHieRoots :: [FilePath] -> IO HieCollection +collectHieRoots = + foldlM + (\collection root -> collectPath RootContext root collection) + emptyHieCollection + . sort + +collectPath :: + TraversalContext -> + FilePath -> + HieCollection -> + IO HieCollection +collectPath context path collection = do + pathKindResult <- classifyPath path + case pathKindResult of + Left message -> + pure (recordTraversalFailure context path message collection) + Right MissingPath -> + pure (recordTraversalFailure context path "no such file or directory" collection) + Right DirectorySymlinkPath -> + pure + ( case context of + RootContext -> + recordTraversalFailure + RootContext + path + "directory symlink roots are not traversed" + collection + DescendantContext -> + collection + ) + Right DirectoryPath -> + collectDirectory context path collection + Right FilePathKind -> + collectFile context path collection + +classifyPath :: FilePath -> IO (Either String PathKind) +classifyPath path = do + symbolicLinkResult <- tryFilesystem (pathIsSymbolicLink path) + case symbolicLinkResult of + Left message -> + pure (Left message) + Right symbolicLink -> do + directoryResult <- tryFilesystem (doesDirectoryExist path) + fileResult <- tryFilesystem (doesFileExist path) + pure + ( classifyObservedPath symbolicLink + <$> directoryResult + <*> fileResult + ) + +classifyObservedPath :: Bool -> Bool -> Bool -> PathKind +classifyObservedPath symbolicLink directoryExists fileExists + | directoryExists && symbolicLink = + DirectorySymlinkPath + | directoryExists = + DirectoryPath + | fileExists = + FilePathKind + | otherwise = + MissingPath + +collectDirectory :: + TraversalContext -> + FilePath -> + HieCollection -> + IO HieCollection +collectDirectory context directory collection = do + canonicalResult <- canonicalPath directory + case canonicalResult of + Left message -> + pure (recordTraversalFailure context directory message collection) + Right canonicalDirectory + | Set.member canonicalDirectory (hcVisitedDirectories collection) -> + pure collection + | otherwise -> do + entriesResult <- tryFilesystem (listDirectory canonicalDirectory) + case entriesResult of + Left message -> + pure (recordTraversalFailure context directory message collection) + Right entries -> + foldlM + (\nextCollection entry -> collectPath DescendantContext (canonicalDirectory entry) nextCollection) + collection + { hcVisitedDirectories = + Set.insert canonicalDirectory (hcVisitedDirectories collection) + } + (sort (filter (not . isPrefixOf ".") entries)) + +collectFile :: + TraversalContext -> + FilePath -> + HieCollection -> + IO HieCollection +collectFile context path collection + | not (hieFilePath path) = + pure collection + | otherwise = do + canonicalResult <- canonicalPath path + pure + ( either + (\message -> recordTraversalFailure context path message collection) + (\canonicalFile -> collection {hcFiles = Set.insert canonicalFile (hcFiles collection)}) + canonicalResult + ) + +canonicalPath :: FilePath -> IO (Either String FilePath) +canonicalPath path = + fmap normalise <$> tryFilesystem (canonicalizePath path) + +tryFilesystem :: IO value -> IO (Either String value) +tryFilesystem action = + first show <$> trySynchronousException action + +trySynchronousException :: IO value -> IO (Either SomeException value) +trySynchronousException action = do + result <- try action + case result of + Left exceptionValue -> + case fromException exceptionValue :: Maybe SomeAsyncException of + Just asynchronousException -> + throwIO asynchronousException + Nothing -> + pure (Left exceptionValue) + Right value -> + pure (Right value) + +recordTraversalFailure :: + TraversalContext -> + FilePath -> + String -> + HieCollection -> + HieCollection +recordTraversalFailure context path message collection = + collection + { hcErrorsReversed = + traversalFailure context path message : hcErrorsReversed collection + } + +traversalFailure :: TraversalContext -> FilePath -> String -> HieReadError +traversalFailure RootContext = + HieRootError +traversalFailure DescendantContext = + HieTraversalError + +hieFilePath :: FilePath -> Bool +hieFilePath = + (== ".hie") . takeExtension diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Hie/SourceKey.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Hie/SourceKey.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Hie/SourceKey.hs @@ -0,0 +1,443 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +{-| Source-path keys and indexed lookup for HIE oracle artifacts. -} +module Moonlight.Pale.Ghc.Hie.SourceKey + ( HieSourceKeyKind (..), + TriedKey (..), + HieOracleArtifact (..), + OracleLookup (..), + OracleAttachFailure (..), + HieOracleIndex, + OracleQuery (..), + buildHieOracleIndex, + lookupModuleOracle, + oracleLookupOracle, + oracleAttachFailure, + ) +where + +import Data.Char (isAlpha, toUpper) +import Data.Either (partitionEithers) +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet +import Data.Kind (Type) +import Data.List (intercalate, stripPrefix) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Moonlight.Pale.Ghc.Hie.Oracle (ModuleNameOracle (..)) + +type HieSourceKeyKind :: Type +data HieSourceKeyKind + = GivenPathKey + | AbsolutePathKey + | RootRelativeKey + | ModuleSuffixKey + deriving stock (Eq, Ord, Show, Read, Enum, Bounded) + +type TriedKey :: Type +data TriedKey = TriedKey !HieSourceKeyKind !FilePath + deriving stock (Eq, Ord, Show, Read) + +type HieOracleArtifact :: Type +data HieOracleArtifact = HieOracleArtifact + { hieArtifactPath :: !FilePath, + hieArtifactOracle :: !ModuleNameOracle + } + deriving stock (Eq, Show) + +type OracleLookup :: Type +data OracleLookup + = OracleFound !HieSourceKeyKind !HieOracleArtifact + | OracleMissing ![TriedKey] + | OracleAmbiguous !HieSourceKeyKind !FilePath ![FilePath] + | OracleIndexObstruction ![Int] + deriving stock (Eq, Show) + +type OracleAttachFailure :: Type +data OracleAttachFailure + = OracleLookupMissing ![TriedKey] + | OracleLookupAmbiguous !HieSourceKeyKind !FilePath ![FilePath] + | OracleLookupIndexObstruction ![Int] + deriving stock (Eq, Ord, Show, Read) + +data PathAnchor + = RelativeAnchor + | PosixRootAnchor + | DriveRootAnchor !Char + | UncRootAnchor !String !String + deriving stock (Eq, Ord, Show) + +data CanonicalPath = CanonicalPath + { cpAnchor :: !PathAnchor, + cpComponents :: ![FilePath] + } + deriving stock (Eq, Ord, Show) + +data PathPart + = ComponentPart !FilePath + | AnchorPart !PathAnchor + deriving stock (Eq, Ord, Show) + +newtype OracleId = OracleId Int + deriving stock (Eq, Ord, Show) + +data CandidateSummary + = NoCandidate + | OneCandidate !OracleId + | ManyCandidates !IntSet + deriving stock (Eq, Show) + +data PathTrie = PathTrie + { ptTerminal :: !CandidateSummary, + ptDescendants :: !CandidateSummary, + ptChildren :: !(Map PathPart PathTrie) + } + deriving stock (Eq, Show) + +data HieOracleIndex = HieOracleIndex + { hoiArtifacts :: !(Vector HieOracleArtifact), + hoiPaths :: !PathTrie + } + deriving stock (Eq, Show) + +type OracleQuery :: Type +data OracleQuery = OracleQuery + { oqGivenPath :: !FilePath, + oqAbsolutePath :: !(Maybe FilePath), + oqSourceRoots :: ![FilePath] + } + deriving stock (Eq, Show) + +buildHieOracleIndex :: [HieOracleArtifact] -> HieOracleIndex +buildHieOracleIndex artifacts = + HieOracleIndex + { hoiArtifacts = Vector.fromList artifacts, + hoiPaths = + foldl' + ( \pathTrie (oracleIndex, artifact) -> + insertPath + (OracleId oracleIndex) + (canonicalPath (mnoSourcePath (hieArtifactOracle artifact))) + pathTrie + ) + emptyPathTrie + (zip [0 ..] artifacts) + } + +lookupModuleOracle :: HieOracleIndex -> OracleQuery -> OracleLookup +lookupModuleOracle oracleIndex query = + case firstExactLookup oracleIndex (exactQueryKeys query) of + Just exactResult -> + exactResult + Nothing -> + maybe + (OracleMissing (exactTriedKeys query <> suffixTriedKeys query)) + ( \(matchedPath, candidates) -> + lookupOutcome + oracleIndex + ModuleSuffixKey + (renderCanonicalPath matchedPath) + candidates + ) + (deepestSuffixCandidates (canonicalPath (oqGivenPath query)) (hoiPaths oracleIndex)) + +firstExactLookup :: HieOracleIndex -> [(HieSourceKeyKind, CanonicalPath)] -> Maybe OracleLookup +firstExactLookup oracleIndex = + foldr + ( \(keyKind, pathValue) next -> + case exactCandidates pathValue (hoiPaths oracleIndex) of + NoCandidate -> + next + candidates -> + Just + ( lookupOutcome + oracleIndex + keyKind + (renderCanonicalPath pathValue) + candidates + ) + ) + Nothing + +lookupOutcome :: HieOracleIndex -> HieSourceKeyKind -> FilePath -> CandidateSummary -> OracleLookup +lookupOutcome oracleIndex keyKind matchedKey candidates = + case candidateArtifacts candidates (hoiArtifacts oracleIndex) of + Left missingOracleIds -> + OracleIndexObstruction missingOracleIds + Right [] -> + OracleMissing [TriedKey keyKind matchedKey] + Right [artifact] -> + OracleFound keyKind artifact + Right ambiguous -> + OracleAmbiguous keyKind matchedKey (fmap hieArtifactPath ambiguous) + +candidateArtifacts :: CandidateSummary -> Vector HieOracleArtifact -> Either [Int] [HieOracleArtifact] +candidateArtifacts summary artifacts = + case + partitionEithers + ( fmap + ( \artifactIndex -> + maybe + (Left artifactIndex) + Right + (artifacts Vector.!? artifactIndex) + ) + (IntSet.toAscList (candidateIds summary)) + ) + of + ([], foundArtifacts) -> + Right foundArtifacts + (missingArtifactIds, _) -> + Left missingArtifactIds + +candidateIds :: CandidateSummary -> IntSet +candidateIds = \case + NoCandidate -> + IntSet.empty + OneCandidate (OracleId oracleId) -> + IntSet.singleton oracleId + ManyCandidates oracleIds -> + oracleIds + +oracleLookupOracle :: OracleLookup -> Maybe ModuleNameOracle +oracleLookupOracle = \case + OracleFound _ artifact -> + Just (hieArtifactOracle artifact) + OracleMissing _ -> + Nothing + OracleAmbiguous _ _ _ -> + Nothing + OracleIndexObstruction _ -> + Nothing + +oracleAttachFailure :: OracleLookup -> Maybe OracleAttachFailure +oracleAttachFailure = \case + OracleFound {} -> + Nothing + OracleMissing triedKeys -> + Just (OracleLookupMissing triedKeys) + OracleAmbiguous keyKind keyValue candidates -> + Just (OracleLookupAmbiguous keyKind keyValue candidates) + OracleIndexObstruction missingOracleIds -> + Just (OracleLookupIndexObstruction missingOracleIds) + +emptyPathTrie :: PathTrie +emptyPathTrie = + PathTrie + { ptTerminal = NoCandidate, + ptDescendants = NoCandidate, + ptChildren = Map.empty + } + +insertPath :: OracleId -> CanonicalPath -> PathTrie -> PathTrie +insertPath oracleId pathValue = + insertParts + (fmap ComponentPart (reverse (cpComponents pathValue)) <> [AnchorPart (cpAnchor pathValue)]) + where + insertParts parts pathTrie = + case parts of + [] -> + pathTrie + { ptTerminal = insertCandidate oracleId (ptTerminal pathTrie), + ptDescendants = insertCandidate oracleId (ptDescendants pathTrie) + } + pathPart : remaining -> + pathTrie + { ptDescendants = insertCandidate oracleId (ptDescendants pathTrie), + ptChildren = + Map.alter + ( Just + . insertParts remaining + . maybe emptyPathTrie id + ) + pathPart + (ptChildren pathTrie) + } + +insertCandidate :: OracleId -> CandidateSummary -> CandidateSummary +insertCandidate oracleId = \case + NoCandidate -> + OneCandidate oracleId + OneCandidate existing + | existing == oracleId -> + OneCandidate existing + | otherwise -> + ManyCandidates + (IntSet.fromList [oracleIdInt existing, oracleIdInt oracleId]) + ManyCandidates existing -> + ManyCandidates (IntSet.insert (oracleIdInt oracleId) existing) + +oracleIdInt :: OracleId -> Int +oracleIdInt (OracleId oracleId) = + oracleId + +exactCandidates :: CanonicalPath -> PathTrie -> CandidateSummary +exactCandidates pathValue = + descend + (fmap ComponentPart (reverse (cpComponents pathValue)) <> [AnchorPart (cpAnchor pathValue)]) + where + descend parts pathTrie = + case parts of + [] -> + ptTerminal pathTrie + pathPart : remaining -> + maybe + NoCandidate + (descend remaining) + (Map.lookup pathPart (ptChildren pathTrie)) + +deepestSuffixCandidates :: CanonicalPath -> PathTrie -> Maybe (CanonicalPath, CandidateSummary) +deepestSuffixCandidates queryPath = + descend Nothing [] (reverse (cpComponents queryPath)) + where + descend best matchedComponents remaining pathTrie = + case remaining of + [] -> + best + component : nextComponents -> + case Map.lookup (ComponentPart component) (ptChildren pathTrie) of + Nothing -> + best + Just childTrie -> + let nextMatchedComponents = component : matchedComponents + nextBest = + case ptDescendants childTrie of + NoCandidate -> + best + candidates -> + Just + ( CanonicalPath RelativeAnchor nextMatchedComponents, + candidates + ) + in descend nextBest nextMatchedComponents nextComponents childTrie + +exactQueryKeys :: OracleQuery -> [(HieSourceKeyKind, CanonicalPath)] +exactQueryKeys query = + [(GivenPathKey, canonicalPath (oqGivenPath query))] + <> maybe [] (\absolutePath -> [(AbsolutePathKey, canonicalPath absolutePath)]) (oqAbsolutePath query) + <> fmap (\relativePath -> (RootRelativeKey, relativePath)) (rootRelativePaths query) + +exactTriedKeys :: OracleQuery -> [TriedKey] +exactTriedKeys = + mapMaybe + ( \(keyKind, pathValue) -> + case renderCanonicalPath pathValue of + "" -> + Nothing + renderedPath -> + Just (TriedKey keyKind renderedPath) + ) + . exactQueryKeys + +rootRelativePaths :: OracleQuery -> [CanonicalPath] +rootRelativePaths query = + [ relativePath + | root <- fmap canonicalPath (oqSourceRoots query), + pathValue <- + canonicalPath (oqGivenPath query) + : maybe [] (pure . canonicalPath) (oqAbsolutePath query), + Just relativePath <- [stripCanonicalRoot root pathValue] + ] + +stripCanonicalRoot :: CanonicalPath -> CanonicalPath -> Maybe CanonicalPath +stripCanonicalRoot root pathValue + | cpAnchor root /= cpAnchor pathValue = + Nothing + | otherwise = + CanonicalPath RelativeAnchor + <$> stripPrefix (cpComponents root) (cpComponents pathValue) + +suffixTriedKeys :: OracleQuery -> [TriedKey] +suffixTriedKeys query = + fmap + (TriedKey ModuleSuffixKey . renderCanonicalPath . CanonicalPath RelativeAnchor) + (componentSuffixes (cpComponents (canonicalPath (oqGivenPath query)))) + +componentSuffixes :: [FilePath] -> [[FilePath]] +componentSuffixes components = + case components of + [] -> + [] + _ : remaining -> + components : componentSuffixes remaining + +canonicalPath :: FilePath -> CanonicalPath +canonicalPath rawPath = + case rawPath of + firstSeparator : secondSeparator : remaining + | pathSeparator firstSeparator, + pathSeparator secondSeparator -> + case splitPathComponents remaining of + server : share : components -> + CanonicalPath + (UncRootAnchor server share) + (normaliseComponents True components) + components -> + CanonicalPath PosixRootAnchor (normaliseComponents True components) + driveLetter : ':' : remaining + | isAlpha driveLetter -> + CanonicalPath + (DriveRootAnchor (toUpper driveLetter)) + (normaliseComponents True (splitPathComponents remaining)) + firstSeparator : remaining + | pathSeparator firstSeparator -> + CanonicalPath + PosixRootAnchor + (normaliseComponents True (splitPathComponents remaining)) + _ -> + CanonicalPath + RelativeAnchor + (normaliseComponents False (splitPathComponents rawPath)) + +splitPathComponents :: FilePath -> [FilePath] +splitPathComponents pathValue = + case dropWhile pathSeparator pathValue of + [] -> + [] + remaining -> + let (component, next) = break pathSeparator remaining + in component : splitPathComponents next + +normaliseComponents :: Bool -> [FilePath] -> [FilePath] +normaliseComponents rooted = + reverse . foldl' normaliseComponent [] + where + normaliseComponent reversedComponents component + | component == "." || null component = + reversedComponents + | component == ".." = + case reversedComponents of + previous : remaining + | previous /= ".." -> + remaining + _ + | rooted -> + reversedComponents + | otherwise -> + ".." : reversedComponents + | otherwise = + component : reversedComponents + +renderCanonicalPath :: CanonicalPath -> FilePath +renderCanonicalPath pathValue = + let componentText = intercalate "/" (cpComponents pathValue) + in case cpAnchor pathValue of + RelativeAnchor -> + componentText + PosixRootAnchor -> + "/" <> componentText + DriveRootAnchor driveLetter -> + driveLetter : ':' : '/' : componentText + UncRootAnchor server share -> + "//" <> server <> "/" <> share + <> if null componentText + then "" + else "/" <> componentText + +pathSeparator :: Char -> Bool +pathSeparator character = + character == '/' || character == '\\' diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Hie/TypeWords.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Hie/TypeWords.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Hie/TypeWords.hs @@ -0,0 +1,992 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +{-| Canonical word encodings of HIE type graphs. -} +module Moonlight.Pale.Ghc.Hie.TypeWords + ( TypeWords, + TypeWord (..), + TypeWordOpcode (..), + TypeArgumentVisibility (..), + TypeVariableFlavor (..), + TypeGraphObstruction (..), + TypeWireFailure (..), + typeWords, + typeWordsList, + tyConTypeWords, + hieTypeIndexTypeWords, + hieTypeRootsTypeWords, + ) +where + +import Control.Monad (foldM) +import Data.Array (Array, bounds, elems, inRange) +import Data.Foldable (toList) +import Data.Kind (Type) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Sequence (Seq, (|>)) +import Data.Sequence qualified as Seq +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Data.Word (Word64) +import GHC.Iface.Ext.Types (HieArgs (..), HieType (..), HieTypeFlat, TypeIndex) +import GHC.Iface.Type (IfaceTyCon, IfaceTyLit (..), ifaceTyConInfo, ifaceTyConName) +import GHC.Types.Name (Name, nameUnique) +import GHC.Types.Unique (getKey) +import GHC.Utils.Outputable (Outputable, ppr, showSDocUnsafe) +import Numeric.Natural (Natural) +import Moonlight.Pale.Ghc.Hie.TypeWords.Internal + +type TypeGraphObstruction :: Type +data TypeGraphObstruction + = MissingTypeIndex !TypeIndex + | CyclicTypeIndex !TypeIndex + | MissingCompiledTypeNode !Natural + | MissingTypeVariableScopeSection !Natural + | EscapedBoundTypeVariable !TypeIndex !Word64 + deriving stock (Eq, Ord, Show) + +newtype TypeNodeId = TypeNodeId Natural + deriving stock (Eq, Ord, Show) + +newtype TypeBinderId = TypeBinderId Natural + deriving stock (Eq, Ord, Show) + +newtype BinderScopeId = BinderScopeId Natural + deriving stock (Eq, Ord, Show) + +data TypeArgument = TypeArgument + { taVisibility :: !TypeArgumentVisibility, + taNode :: !TypeNodeId + } + deriving stock (Eq, Ord, Show) + +data TypeVariableReference + = BoundTypeVariable !TypeBinderId + | FreeTypeVariable !Name + deriving stock (Eq, Ord) + +instance Show TypeVariableReference where + showsPrec precedence = \case + BoundTypeVariable binderId -> + showParen (precedence > 10) (showString "BoundTypeVariable " . showsPrec 11 binderId) + FreeTypeVariable nameValue -> + showParen (precedence > 10) (showString "FreeTypeVariable " . showsPrec 11 (getKey (nameUnique nameValue))) + +data TypeNode + = TypeApplication !TypeNodeId ![TypeArgument] + | TypeFunction !TypeNodeId !TypeNodeId !TypeNodeId + | TypeQualified !TypeNodeId !TypeNodeId + | TypeForAll !TypeBinderId !TypeNodeId !String !TypeNodeId + | TypeVariable !TypeVariableReference + | TypeCast !TypeNodeId + | TypeCoercion + | TypeConstructor !IfaceTyCon ![TypeArgument] + | TypeLiteral !IfaceTyLit + deriving stock (Eq, Ord) + +data FlatTypeGraph = FlatTypeGraph + { ftBounds :: !(TypeIndex, TypeIndex), + ftNodes :: !(Vector HieTypeFlat) + } + +data BinderScope = BinderScope + { bsId :: !BinderScopeId, + bsNames :: !(Map Name TypeBinderId), + bsDepth :: !Natural + } + +data ScopedTypeKey = ScopedTypeKey !TypeIndex !BinderScopeId + deriving stock (Eq, Ord) + +data TypeVariableScopeEvidence + = ObservedFreeTypeVariable !Word64 + | ObservedBoundTypeVariable !Word64 + deriving stock (Eq, Ord) + +newtype TypeVariableScopeSectionId = + TypeVariableScopeSectionId Natural + deriving stock (Eq, Ord, Show) + +data TypeVariableScopeSection + = TypeVariableScopeLeaf !TypeIndex !TypeVariableScopeEvidence + | TypeVariableScopeUnion + !TypeVariableScopeSectionId + !TypeVariableScopeSectionId + deriving stock (Eq, Ord) + +data TypeNodeSection node = TypeNodeSection + { tnsNode :: !node, + tnsVariableScopes :: !TypeVariableScopeSectionId + } + +-- Evidence-free entries remain absent from the sparse evidence map. This +-- preserves the allocation profile of variable-free type graphs while keeping +-- node identity and its contextual evidence under one memo owner. +data ScopedTypeMemo = ScopedTypeMemo + { stmNodes :: !(Map ScopedTypeKey TypeNodeId), + stmVariableScopes :: !(Map ScopedTypeKey TypeVariableScopeSectionId), + stmNextVariableScopeSection :: !Natural, + stmVariableScopeSections :: + !(Map TypeVariableScopeSectionId TypeVariableScopeSection), + stmVariableScopeSectionIntern :: + !(Map TypeVariableScopeSection TypeVariableScopeSectionId) + } + +data GraphBuild = GraphBuild + { gbNextNode :: !Natural, + gbNextScope :: !Natural, + gbScopeIntern :: !(Map (BinderScopeId, Name, TypeBinderId) BinderScopeId), + gbMemo :: {-# UNPACK #-} !ScopedTypeMemo, + gbActive :: !(Set TypeIndex), + gbNodes :: !(Map TypeNodeId TypeNode), + gbIntern :: !(Map TypeNode TypeNodeId), + gbVariableScopes :: !(Map TypeIndex TypeVariableScopeEvidence), + gbReplayedVariableScopeSections :: !(Set TypeVariableScopeSectionId) + } + +tyConTypeWords :: String -> TypeWords +tyConTypeWords tyConName = + trustedTypeWords + [ TypeOpcode TypeGraphOpcode, + TypeRootReference 0, + TypeDefinitionCount 1, + TypeDefinitionId 0, + TypeOpcode TypeTyConAppOpcode, + TypeOutputText tyConName, + TypeArgumentCount 0 + ] + +hieTypeIndexTypeWords :: Array TypeIndex HieTypeFlat -> TypeIndex -> Either TypeGraphObstruction TypeWords +hieTypeIndexTypeWords typeTable rootIndex = + maybe + (Left (MissingTypeIndex rootIndex)) + id + (Map.lookup rootIndex (hieTypeRootsTypeWords typeTable (Set.singleton rootIndex))) + +hieTypeRootsTypeWords :: + Array TypeIndex HieTypeFlat -> + Set TypeIndex -> + Map TypeIndex (Either TypeGraphObstruction TypeWords) +hieTypeRootsTypeWords typeTable rootIndices = + let flatTypeGraph = + FlatTypeGraph + { ftBounds = bounds typeTable, + ftNodes = Vector.fromList (elems typeTable) + } + (compiledRoots, completedBuild) = + Set.foldl' + (compileRoot flatTypeGraph) + (Map.empty, emptyGraphBuild) + rootIndices + in fmap + (>>= renderCompiledRoot (gbNodes completedBuild)) + compiledRoots + +emptyScopedTypeMemo :: ScopedTypeMemo +emptyScopedTypeMemo = + ScopedTypeMemo + { stmNodes = Map.empty, + stmVariableScopes = Map.empty, + stmNextVariableScopeSection = 1, + stmVariableScopeSections = Map.empty, + stmVariableScopeSectionIntern = Map.empty + } + +emptyTypeVariableScopeSectionId :: TypeVariableScopeSectionId +emptyTypeVariableScopeSectionId = + TypeVariableScopeSectionId 0 + +lookupScopedTypeMemo :: + ScopedTypeKey -> + ScopedTypeMemo -> + Maybe (TypeNodeSection TypeNodeId) +lookupScopedTypeMemo scopedKey scopedMemo = + ( \nodeId -> + TypeNodeSection + { tnsNode = nodeId, + tnsVariableScopes = + Map.findWithDefault + emptyTypeVariableScopeSectionId + scopedKey + (stmVariableScopes scopedMemo) + } + ) + <$> Map.lookup scopedKey (stmNodes scopedMemo) + +insertScopedTypeMemo :: + ScopedTypeKey -> + TypeNodeSection TypeNodeId -> + ScopedTypeMemo -> + ScopedTypeMemo +insertScopedTypeMemo scopedKey nodeSection scopedMemo = + ScopedTypeMemo + { stmNodes = + Map.insert scopedKey (tnsNode nodeSection) (stmNodes scopedMemo), + stmVariableScopes = + if tnsVariableScopes nodeSection == emptyTypeVariableScopeSectionId + then Map.delete scopedKey (stmVariableScopes scopedMemo) + else + Map.insert + scopedKey + (tnsVariableScopes nodeSection) + (stmVariableScopes scopedMemo), + stmNextVariableScopeSection = + stmNextVariableScopeSection scopedMemo, + stmVariableScopeSections = + stmVariableScopeSections scopedMemo, + stmVariableScopeSectionIntern = + stmVariableScopeSectionIntern scopedMemo + } + +internTypeVariableScopeSection :: + TypeVariableScopeSection -> + ScopedTypeMemo -> + (TypeVariableScopeSectionId, ScopedTypeMemo) +internTypeVariableScopeSection variableScopeSection scopedMemo = + case + Map.lookup + variableScopeSection + (stmVariableScopeSectionIntern scopedMemo) + of + Just knownSectionId -> + (knownSectionId, scopedMemo) + Nothing -> + let sectionId = + TypeVariableScopeSectionId + (stmNextVariableScopeSection scopedMemo) + in ( sectionId, + scopedMemo + { stmNextVariableScopeSection = + stmNextVariableScopeSection scopedMemo + 1, + stmVariableScopeSections = + Map.insert + sectionId + variableScopeSection + (stmVariableScopeSections scopedMemo), + stmVariableScopeSectionIntern = + Map.insert + variableScopeSection + sectionId + (stmVariableScopeSectionIntern scopedMemo) + } + ) + +emptyGraphBuild :: GraphBuild +emptyGraphBuild = + GraphBuild + { gbNextNode = 0, + gbNextScope = 1, + gbScopeIntern = Map.empty, + gbMemo = emptyScopedTypeMemo, + gbActive = Set.empty, + gbNodes = Map.empty, + gbIntern = Map.empty, + gbVariableScopes = Map.empty, + gbReplayedVariableScopeSections = Set.empty + } + +compileRoot :: + FlatTypeGraph -> + (Map TypeIndex (Either TypeGraphObstruction TypeNodeId), GraphBuild) -> + TypeIndex -> + (Map TypeIndex (Either TypeGraphObstruction TypeNodeId), GraphBuild) +compileRoot typeGraph (compiledRoots, graphBuild) rootIndex = + case + buildTypeNode + typeGraph + BinderScope + { bsId = BinderScopeId 0, + bsNames = Map.empty, + bsDepth = 0 + } + rootIndex + graphBuild + { gbActive = Set.empty, + gbVariableScopes = Map.empty, + gbReplayedVariableScopeSections = Set.empty + } + of + Left obstruction -> + (Map.insert rootIndex (Left obstruction) compiledRoots, graphBuild) + Right (rootSection, nextBuild) -> + (Map.insert rootIndex (Right (tnsNode rootSection)) compiledRoots, nextBuild) + +buildTypeNode :: + FlatTypeGraph -> + BinderScope -> + TypeIndex -> + GraphBuild -> + Either TypeGraphObstruction (TypeNodeSection TypeNodeId, GraphBuild) +buildTypeNode typeGraph binderScope typeIndex graphBuild = + case flatTypeAt typeGraph typeIndex of + Nothing -> + Left (MissingTypeIndex typeIndex) + Just flatType + | Set.member typeIndex (gbActive graphBuild) -> + Left (CyclicTypeIndex typeIndex) + | Just knownSection <- lookupScopedTypeMemo scopedKey (gbMemo graphBuild) -> do + scopedBuild <- + replayTypeVariableScopeSection + (tnsVariableScopes knownSection) + graphBuild + pure (knownSection, scopedBuild) + | otherwise -> do + let activeBuild = + graphBuild + { gbActive = Set.insert typeIndex (gbActive graphBuild) + } + (nodeSection, descendantBuild) <- + buildFlatType typeGraph binderScope typeIndex flatType activeBuild + let inactiveBuild = + descendantBuild + { gbActive = Set.delete typeIndex (gbActive descendantBuild) + } + nodeValue = + tnsNode nodeSection + case Map.lookup nodeValue (gbIntern inactiveBuild) of + Just internedNode -> + let internedSection = + nodeSection {tnsNode = internedNode} + in pure + ( internedSection, + inactiveBuild + { gbMemo = + insertScopedTypeMemo + scopedKey + internedSection + (gbMemo inactiveBuild) + } + ) + Nothing -> + let nodeId = + TypeNodeId (gbNextNode inactiveBuild) + compiledSection = + nodeSection {tnsNode = nodeId} + in pure + ( compiledSection, + inactiveBuild + { gbNextNode = gbNextNode inactiveBuild + 1, + gbMemo = + insertScopedTypeMemo + scopedKey + compiledSection + (gbMemo inactiveBuild), + gbNodes = Map.insert nodeId nodeValue (gbNodes inactiveBuild), + gbIntern = Map.insert nodeValue nodeId (gbIntern inactiveBuild) + } + ) + where + scopedKey = + ScopedTypeKey typeIndex (bsId binderScope) + +flatTypeAt :: FlatTypeGraph -> TypeIndex -> Maybe HieTypeFlat +flatTypeAt typeGraph typeIndex + | inRange (ftBounds typeGraph) typeIndex = + let (lowerBound, _) = ftBounds typeGraph + in ftNodes typeGraph Vector.!? fromIntegral (typeIndex - lowerBound) + | otherwise = + Nothing + +buildFlatType :: + FlatTypeGraph -> + BinderScope -> + TypeIndex -> + HieTypeFlat -> + GraphBuild -> + Either TypeGraphObstruction (TypeNodeSection TypeNode, GraphBuild) +buildFlatType typeGraph binderScope typeIndex flatType = + case flatType of + HAppTy functionType argumentTypes -> + buildNodeThenArguments TypeApplication functionType argumentTypes + HFunTy multiplicityType argumentType resultType -> + buildThree TypeFunction multiplicityType argumentType resultType + HQualTy predicateType bodyType -> + buildTwo TypeQualified predicateType bodyType + HForAllTy ((binderName, binderKind), flagValue) bodyType -> + buildForAll binderName binderKind flagValue bodyType + HTyVarTy nameValue -> + \graphBuild -> do + let binderReference = + Map.lookup nameValue (bsNames binderScope) + (variableScopes, scopedBuild) <- + observeTypeVariable + typeIndex + nameValue + binderReference + graphBuild + pure + ( TypeNodeSection + { tnsNode = + TypeVariable + ( maybe + (FreeTypeVariable nameValue) + BoundTypeVariable + binderReference + ), + tnsVariableScopes = variableScopes + }, + scopedBuild + ) + HCastTy castType -> + buildOne TypeCast castType + HCoercionTy -> + \graphBuild -> + Right + ( TypeNodeSection + { tnsNode = TypeCoercion, + tnsVariableScopes = emptyTypeVariableScopeSectionId + }, + graphBuild + ) + HTyConApp tyCon argumentTypes -> + buildArguments (TypeConstructor tyCon) argumentTypes + HLitTy literalType -> + \graphBuild -> + Right + ( TypeNodeSection + { tnsNode = TypeLiteral literalType, + tnsVariableScopes = emptyTypeVariableScopeSectionId + }, + graphBuild + ) + where + buildOne constructor childIndex build = do + (childSection, nextBuild) <- + buildTypeNode typeGraph binderScope childIndex build + pure + ( TypeNodeSection + { tnsNode = constructor (tnsNode childSection), + tnsVariableScopes = tnsVariableScopes childSection + }, + nextBuild + ) + + buildTwo constructor firstIndex secondIndex build = do + (firstSection, afterFirst) <- + buildTypeNode typeGraph binderScope firstIndex build + (secondSection, afterSecond) <- + buildTypeNode typeGraph binderScope secondIndex afterFirst + let (variableScopes, gluedBuild) = + glueTypeVariableScopeSections + (tnsVariableScopes firstSection) + (tnsVariableScopes secondSection) + afterSecond + pure + ( TypeNodeSection + { tnsNode = + constructor + (tnsNode firstSection) + (tnsNode secondSection), + tnsVariableScopes = variableScopes + }, + gluedBuild + ) + + buildThree constructor firstIndex secondIndex thirdIndex build = do + (firstSection, afterFirst) <- + buildTypeNode typeGraph binderScope firstIndex build + (secondSection, afterSecond) <- + buildTypeNode typeGraph binderScope secondIndex afterFirst + (thirdSection, afterThird) <- + buildTypeNode typeGraph binderScope thirdIndex afterSecond + let (firstAndSecondScopes, afterFirstGlue) = + glueTypeVariableScopeSections + (tnsVariableScopes firstSection) + (tnsVariableScopes secondSection) + afterThird + (variableScopes, gluedBuild) = + glueTypeVariableScopeSections + firstAndSecondScopes + (tnsVariableScopes thirdSection) + afterFirstGlue + pure + ( TypeNodeSection + { tnsNode = + constructor + (tnsNode firstSection) + (tnsNode secondSection) + (tnsNode thirdSection), + tnsVariableScopes = variableScopes + }, + gluedBuild + ) + + buildArguments constructor arguments build = do + (argumentSection, nextBuild) <- + buildHieArguments typeGraph binderScope arguments build + pure + ( TypeNodeSection + { tnsNode = constructor (tnsNode argumentSection), + tnsVariableScopes = tnsVariableScopes argumentSection + }, + nextBuild + ) + + buildNodeThenArguments constructor functionIndex arguments build = do + (functionSection, afterFunction) <- + buildTypeNode typeGraph binderScope functionIndex build + (argumentSection, afterArguments) <- + buildHieArguments typeGraph binderScope arguments afterFunction + let (variableScopes, gluedBuild) = + glueTypeVariableScopeSections + (tnsVariableScopes functionSection) + (tnsVariableScopes argumentSection) + afterArguments + pure + ( TypeNodeSection + { tnsNode = + constructor + (tnsNode functionSection) + (tnsNode argumentSection), + tnsVariableScopes = variableScopes + }, + gluedBuild + ) + + buildForAll binderName binderKind flagValue bodyType build = do + let binderId = TypeBinderId (bsDepth binderScope) + (kindSection, afterKind) <- + buildTypeNode typeGraph binderScope binderKind build + let (bodyScope, scopedBuild) = + extendBinderScope binderScope binderName binderId afterKind + (bodySection, afterBody) <- + buildTypeNode + typeGraph + bodyScope + bodyType + scopedBuild + let (variableScopes, gluedBuild) = + glueTypeVariableScopeSections + (tnsVariableScopes kindSection) + (tnsVariableScopes bodySection) + afterBody + pure + ( TypeNodeSection + { tnsNode = + TypeForAll + binderId + (tnsNode kindSection) + (outputString flagValue) + (tnsNode bodySection), + tnsVariableScopes = variableScopes + }, + gluedBuild + ) + +extendBinderScope :: + BinderScope -> + Name -> + TypeBinderId -> + GraphBuild -> + (BinderScope, GraphBuild) +extendBinderScope parentScope binderName binderId graphBuild = + case Map.lookup transitionKey (gbScopeIntern graphBuild) of + Just knownScopeId -> + (bodyScope knownScopeId, graphBuild) + Nothing -> + let scopeId = BinderScopeId (gbNextScope graphBuild) + in ( bodyScope scopeId, + graphBuild + { gbNextScope = gbNextScope graphBuild + 1, + gbScopeIntern = + Map.insert transitionKey scopeId (gbScopeIntern graphBuild) + } + ) + where + transitionKey = + (bsId parentScope, binderName, binderId) + + bodyScope scopeId = + BinderScope + { bsId = scopeId, + bsNames = Map.insert binderName binderId (bsNames parentScope), + bsDepth = bsDepth parentScope + 1 + } + +observeTypeVariable :: + TypeIndex -> + Name -> + Maybe TypeBinderId -> + GraphBuild -> + Either TypeGraphObstruction (TypeVariableScopeSectionId, GraphBuild) +observeTypeVariable typeIndex nameValue binderReference graphBuild = do + let binderIdentity = + getKey (nameUnique nameValue) + scopeEvidence = + maybe + (ObservedFreeTypeVariable binderIdentity) + (const (ObservedBoundTypeVariable binderIdentity)) + binderReference + (variableScopeSection, sectionedMemo) = + internTypeVariableScopeSection + (TypeVariableScopeLeaf typeIndex scopeEvidence) + (gbMemo graphBuild) + sectionedBuild = + graphBuild {gbMemo = sectionedMemo} + scopedBuild <- + replayTypeVariableScopeSection variableScopeSection sectionedBuild + pure (variableScopeSection, scopedBuild) + +replayTypeVariableScopeSection :: + TypeVariableScopeSectionId -> + GraphBuild -> + Either TypeGraphObstruction GraphBuild +replayTypeVariableScopeSection sectionId graphBuild + | sectionId == emptyTypeVariableScopeSectionId = + Right graphBuild + | Set.member sectionId (gbReplayedVariableScopeSections graphBuild) = + Right graphBuild + | otherwise = + case + Map.lookup + sectionId + (stmVariableScopeSections (gbMemo graphBuild)) + of + Nothing -> + Left + ( MissingTypeVariableScopeSection + (typeVariableScopeSectionIdNatural sectionId) + ) + Just variableScopeSection -> + let markedBuild = + graphBuild + { gbReplayedVariableScopeSections = + Set.insert + sectionId + (gbReplayedVariableScopeSections graphBuild) + } + in case variableScopeSection of + TypeVariableScopeLeaf typeIndex scopeEvidence -> + observeTypeVariableScope + typeIndex + scopeEvidence + markedBuild + TypeVariableScopeUnion leftSection rightSection -> + replayTypeVariableScopeSection leftSection markedBuild + >>= replayTypeVariableScopeSection rightSection + +observeTypeVariableScope :: + TypeIndex -> + TypeVariableScopeEvidence -> + GraphBuild -> + Either TypeGraphObstruction GraphBuild +observeTypeVariableScope typeIndex scopeEvidence graphBuild = + case Map.lookup typeIndex (gbVariableScopes graphBuild) of + Nothing -> + Right + graphBuild + { gbVariableScopes = + Map.insert + typeIndex + scopeEvidence + (gbVariableScopes graphBuild) + } + Just knownEvidence + | compatibleTypeVariableScopes knownEvidence scopeEvidence -> + Right graphBuild + | otherwise -> + Left + ( EscapedBoundTypeVariable + typeIndex + (typeVariableScopeIdentity scopeEvidence) + ) + +glueTypeVariableScopeSections :: + TypeVariableScopeSectionId -> + TypeVariableScopeSectionId -> + GraphBuild -> + (TypeVariableScopeSectionId, GraphBuild) +-- Both children have already replayed successfully into the current root. +-- Gluing therefore composes canonical section ids without rescanning leaves. +glueTypeVariableScopeSections leftSection rightSection graphBuild + | leftSection == emptyTypeVariableScopeSectionId = + (rightSection, graphBuild) + | rightSection == emptyTypeVariableScopeSectionId = + (leftSection, graphBuild) + | leftSection == rightSection = + (leftSection, graphBuild) + | otherwise = + let (lowerSection, upperSection) = + if leftSection <= rightSection + then (leftSection, rightSection) + else (rightSection, leftSection) + (gluedSection, gluedMemo) = + internTypeVariableScopeSection + (TypeVariableScopeUnion lowerSection upperSection) + (gbMemo graphBuild) + in (gluedSection, graphBuild {gbMemo = gluedMemo}) + +compatibleTypeVariableScopes :: + TypeVariableScopeEvidence -> + TypeVariableScopeEvidence -> + Bool +compatibleTypeVariableScopes leftEvidence rightEvidence = + case (leftEvidence, rightEvidence) of + (ObservedFreeTypeVariable _, ObservedFreeTypeVariable _) -> + True + (ObservedBoundTypeVariable _, ObservedBoundTypeVariable _) -> + True + _ -> + False + +typeVariableScopeIdentity :: TypeVariableScopeEvidence -> Word64 +typeVariableScopeIdentity = \case + ObservedFreeTypeVariable binderIdentity -> + binderIdentity + ObservedBoundTypeVariable binderIdentity -> + binderIdentity + +typeVariableScopeSectionIdNatural :: + TypeVariableScopeSectionId -> + Natural +typeVariableScopeSectionIdNatural (TypeVariableScopeSectionId sectionId) = + sectionId + +buildHieArguments :: + FlatTypeGraph -> + BinderScope -> + HieArgs TypeIndex -> + GraphBuild -> + Either TypeGraphObstruction (TypeNodeSection [TypeArgument], GraphBuild) +buildHieArguments typeGraph binderScope (HieArgs arguments) = + buildArguments arguments + where + buildArguments [] graphBuild = + pure + ( TypeNodeSection + { tnsNode = [], + tnsVariableScopes = emptyTypeVariableScopeSectionId + }, + graphBuild + ) + buildArguments ((visible, typeIndex) : remaining) graphBuild = do + (argumentSection, afterArgument) <- + buildTypeNode typeGraph binderScope typeIndex graphBuild + (remainingSection, afterRemaining) <- + buildArguments remaining afterArgument + let (variableScopes, gluedBuild) = + glueTypeVariableScopeSections + (tnsVariableScopes argumentSection) + (tnsVariableScopes remainingSection) + afterRemaining + pure + ( TypeNodeSection + { tnsNode = + TypeArgument + { taVisibility = + if visible + then TypeArgumentVisible + else TypeArgumentHidden, + taNode = tnsNode argumentSection + } + : tnsNode remainingSection, + tnsVariableScopes = variableScopes + }, + gluedBuild + ) + +data LocalNumbering = LocalNumbering + { lnNextNode :: !Natural, + lnNodeIds :: !(Map TypeNodeId TypeNodeId), + lnTraversalOrder :: !(Seq TypeNodeId) + } + +renderCompiledRoot :: + Map TypeNodeId TypeNode -> + TypeNodeId -> + Either TypeGraphObstruction TypeWords +renderCompiledRoot compiledNodes rootNode = do + numbering <- + numberReachableNode + compiledNodes + rootNode + LocalNumbering + { lnNextNode = 0, + lnNodeIds = Map.empty, + lnTraversalOrder = Seq.empty + } + localRoot <- localNodeId numbering rootNode + definitions <- + foldMap id + <$> traverse + (renderDefinition numbering compiledNodes) + (toList (lnTraversalOrder numbering)) + pure + ( trustedTypeWords + ( [ TypeOpcode TypeGraphOpcode, + TypeRootReference (nodeIdNatural localRoot), + TypeDefinitionCount (lnNextNode numbering) + ] + <> definitions + ) + ) + +numberReachableNode :: + Map TypeNodeId TypeNode -> + TypeNodeId -> + LocalNumbering -> + Either TypeGraphObstruction LocalNumbering +numberReachableNode compiledNodes globalNode numbering = + case Map.lookup globalNode (lnNodeIds numbering) of + Just _ -> + Right numbering + Nothing -> + case Map.lookup globalNode compiledNodes of + Nothing -> + Left (MissingCompiledTypeNode (nodeIdNatural globalNode)) + Just nodeValue -> + let localNode = TypeNodeId (lnNextNode numbering) + numbered = + numbering + { lnNextNode = lnNextNode numbering + 1, + lnNodeIds = Map.insert globalNode localNode (lnNodeIds numbering), + lnTraversalOrder = lnTraversalOrder numbering |> globalNode + } + in foldM + (flip (numberReachableNode compiledNodes)) + numbered + (typeNodeChildren nodeValue) + +typeNodeChildren :: TypeNode -> [TypeNodeId] +typeNodeChildren = \case + TypeApplication functionNode arguments -> + functionNode : fmap taNode arguments + TypeFunction multiplicityNode argumentNode resultNode -> + [multiplicityNode, argumentNode, resultNode] + TypeQualified predicateNode bodyNode -> + [predicateNode, bodyNode] + TypeForAll _ kindNode _ bodyNode -> + [kindNode, bodyNode] + TypeVariable _ -> + [] + TypeCast castNode -> + [castNode] + TypeCoercion -> + [] + TypeConstructor _ arguments -> + fmap taNode arguments + TypeLiteral _ -> + [] + +renderDefinition :: + LocalNumbering -> + Map TypeNodeId TypeNode -> + TypeNodeId -> + Either TypeGraphObstruction [TypeWord] +renderDefinition numbering compiledNodes globalNode = do + localNode <- localNodeId numbering globalNode + nodeValue <- + maybe + (Left (MissingCompiledTypeNode (nodeIdNatural globalNode))) + Right + (Map.lookup globalNode compiledNodes) + nodeWords <- renderTypeNode numbering nodeValue + pure (TypeDefinitionId (nodeIdNatural localNode) : nodeWords) + +renderTypeNode :: LocalNumbering -> TypeNode -> Either TypeGraphObstruction [TypeWord] +renderTypeNode numbering = \case + TypeApplication functionNode arguments -> + ( \functionReference argumentWords -> + TypeOpcode TypeAppOpcode : functionReference : argumentWords + ) + <$> localNodeReference numbering functionNode + <*> renderArguments numbering arguments + TypeFunction multiplicityNode argumentNode resultNode -> do + references <- traverse (localNodeReference numbering) [multiplicityNode, argumentNode, resultNode] + pure (TypeOpcode TypeFunOpcode : references) + TypeQualified predicateNode bodyNode -> do + references <- traverse (localNodeReference numbering) [predicateNode, bodyNode] + pure (TypeOpcode TypeQualOpcode : references) + TypeForAll binderId kindNode specificity bodyNode -> do + kindReference <- localNodeReference numbering kindNode + bodyReference <- localNodeReference numbering bodyNode + pure + [ TypeOpcode TypeForAllOpcode, + TypeBinderReference (binderIdNatural binderId), + kindReference, + TypeOutputText specificity, + bodyReference + ] + TypeVariable variableReference -> + pure (TypeOpcode TypeVariableOpcode : renderVariableReference variableReference) + TypeCast castNode -> do + castReference <- localNodeReference numbering castNode + pure [TypeOpcode TypeCastOpcode, castReference] + TypeCoercion -> + pure [TypeOpcode TypeCoercionOpcode] + TypeConstructor tyCon arguments -> + ( \argumentWords -> + TypeOpcode TypeTyConAppOpcode + : TypeNameIdentity (getKey (nameUnique (ifaceTyConName tyCon))) + : TypeOutputText (outputString (ifaceTyConInfo tyCon)) + : TypeOutputText (outputString tyCon) + : argumentWords + ) + <$> renderArguments numbering arguments + TypeLiteral literalValue -> + pure + [ TypeOpcode TypeLiteralOpcode, + TypeOutputText (typeLiteralConstructorName literalValue), + TypeOutputText (outputString literalValue) + ] + +typeLiteralConstructorName :: IfaceTyLit -> String +typeLiteralConstructorName = \case + IfaceNumTyLit {} -> "number" + IfaceStrTyLit {} -> "string" + IfaceCharTyLit {} -> "character" + +renderArguments :: LocalNumbering -> [TypeArgument] -> Either TypeGraphObstruction [TypeWord] +renderArguments numbering arguments = + (TypeArgumentCount (naturalFromInt (length arguments)) :) + . foldMap id + <$> traverse renderArgument arguments + where + renderArgument argumentValue = + ( \reference -> + [ TypeArgumentVisibilityWord (taVisibility argumentValue), + reference + ] + ) + <$> localNodeReference numbering (taNode argumentValue) + +renderVariableReference :: TypeVariableReference -> [TypeWord] +renderVariableReference = \case + BoundTypeVariable binderId -> + [ TypeVariableFlavorWord TypeBoundVariableFlavor, + TypeBinderReference (binderIdNatural binderId) + ] + FreeTypeVariable nameValue -> + TypeVariableFlavorWord TypeFreeVariableFlavor + : TypeNameIdentity (getKey (nameUnique nameValue)) + : outputTypeWords nameValue + +localNodeReference :: LocalNumbering -> TypeNodeId -> Either TypeGraphObstruction TypeWord +localNodeReference numbering = + fmap (TypeNodeReference . nodeIdNatural) . localNodeId numbering + +localNodeId :: LocalNumbering -> TypeNodeId -> Either TypeGraphObstruction TypeNodeId +localNodeId numbering globalNode = + maybe + (Left (MissingCompiledTypeNode (nodeIdNatural globalNode))) + Right + (Map.lookup globalNode (lnNodeIds numbering)) + +nodeIdNatural :: TypeNodeId -> Natural +nodeIdNatural (TypeNodeId nodeId) = + nodeId + +binderIdNatural :: TypeBinderId -> Natural +binderIdNatural (TypeBinderId binderId) = + binderId + +naturalFromInt :: Int -> Natural +naturalFromInt = + fromIntegral + +outputString :: Outputable value => value -> String +outputString = + showSDocUnsafe . ppr diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/Hie/TypeWords/Internal.hs b/src-ghc-surface/Moonlight/Pale/Ghc/Hie/TypeWords/Internal.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/Hie/TypeWords/Internal.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module Moonlight.Pale.Ghc.Hie.TypeWords.Internal + ( TypeWords, + TypeWord (..), + TypeWordOpcode (..), + TypeArgumentVisibility (..), + TypeVariableFlavor (..), + TypeWireFailure (..), + typeWords, + trustedTypeWords, + typeWordsList, + outputTypeWords, + stringTypeWords, + ) +where + +import Data.Kind (Type) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Data.Word (Word64) +import GHC.Utils.Outputable (Outputable, ppr, showSDocUnsafe) +import Numeric.Natural (Natural) + +type TypeWords :: Type +newtype TypeWords = TypeWords (Vector TypeWord) + deriving stock (Eq, Ord, Show) + +type TypeWord :: Type +data TypeWord + = TypeOpcode !TypeWordOpcode + | TypeDefinitionCount !Natural + | TypeDefinitionId !Natural + | TypeRootReference !Natural + | TypeNodeReference !Natural + | TypeArgumentCount !Natural + | TypeArgumentVisibilityWord !TypeArgumentVisibility + | TypeVariableFlavorWord !TypeVariableFlavor + | TypeBinderReference !Natural + | TypeNameIdentity !Word64 + | TypeOutputText !String + deriving stock (Eq, Ord, Show) + +type TypeWordOpcode :: Type +data TypeWordOpcode + = TypeGraphOpcode + | TypeDefinitionOpcode + | TypeAppOpcode + | TypeFunOpcode + | TypeQualOpcode + | TypeForAllOpcode + | TypeVariableOpcode + | TypeCastOpcode + | TypeCoercionOpcode + | TypeTyConAppOpcode + | TypeLiteralOpcode + deriving stock (Eq, Ord, Show, Enum, Bounded) + +type TypeArgumentVisibility :: Type +data TypeArgumentVisibility + = TypeArgumentHidden + | TypeArgumentVisible + deriving stock (Eq, Ord, Show, Enum, Bounded) + +type TypeVariableFlavor :: Type +data TypeVariableFlavor + = TypeFreeVariableFlavor + | TypeBoundVariableFlavor + deriving stock (Eq, Ord, Show, Enum, Bounded) + +type TypeWireFailure :: Type +data TypeWireFailure + = TypeNaturalExceedsWord64 !TypeWord + deriving stock (Eq, Ord, Show) + +typeWords :: [TypeWord] -> Either TypeWireFailure TypeWords +typeWords wordsValue = + TypeWords (Vector.fromList wordsValue) + <$ traverse validateTypeWord wordsValue + +trustedTypeWords :: [TypeWord] -> TypeWords +trustedTypeWords = + TypeWords . Vector.fromList + +typeWordsList :: TypeWords -> [Word64] +typeWordsList (TypeWords wordsValue) = + foldMap renderTypeWord wordsValue + +outputTypeWords :: Outputable value => value -> [TypeWord] +outputTypeWords = + stringTypeWords . outputString + +stringTypeWords :: String -> [TypeWord] +stringTypeWords textValue = + [TypeOutputText textValue] + +validateTypeWord :: TypeWord -> Either TypeWireFailure () +validateTypeWord wordValue = + case wordNatural wordValue of + Nothing -> + Right () + Just naturalValue + | naturalValue <= fromIntegral (maxBound :: Word64) -> + Right () + | otherwise -> + Left (TypeNaturalExceedsWord64 wordValue) + +wordNatural :: TypeWord -> Maybe Natural +wordNatural = \case + TypeDefinitionCount value -> + Just value + TypeDefinitionId value -> + Just value + TypeRootReference value -> + Just value + TypeNodeReference value -> + Just value + TypeArgumentCount value -> + Just value + TypeBinderReference value -> + Just value + _ -> + Nothing + +renderTypeWord :: TypeWord -> [Word64] +renderTypeWord = \case + TypeOpcode opcode -> + [boundedTagWord opcode] + TypeDefinitionCount count -> + [boundedTagWord TypeGraphOpcode, naturalWord count] + TypeDefinitionId definitionId -> + [boundedTagWord TypeDefinitionOpcode, naturalWord definitionId] + TypeRootReference rootId -> + [naturalWord rootId] + TypeNodeReference nodeId -> + [naturalWord nodeId] + TypeArgumentCount count -> + [naturalWord count] + TypeArgumentVisibilityWord visibility -> + [boundedTagWord visibility] + TypeVariableFlavorWord flavor -> + [boundedTagWord flavor] + TypeBinderReference binderId -> + [naturalWord binderId] + TypeNameIdentity uniqueWord -> + [uniqueWord] + TypeOutputText textValue -> + fromIntegral (length textValue) : fmap (fromIntegral . fromEnum) textValue + +boundedTagWord :: Enum tag => tag -> Word64 +boundedTagWord tagValue = + fromIntegral (fromEnum tagValue + 1) + +naturalWord :: Natural -> Word64 +naturalWord = + fromIntegral + +outputString :: Outputable value => value -> String +outputString = + showSDocUnsafe . ppr diff --git a/src-ghc-surface/Moonlight/Pale/Ghc/ModuleSurface.hs b/src-ghc-surface/Moonlight/Pale/Ghc/ModuleSurface.hs new file mode 100644 --- /dev/null +++ b/src-ghc-surface/Moonlight/Pale/Ghc/ModuleSurface.hs @@ -0,0 +1,493 @@ +{-| GHC-parsed module identities, imports, and exports. -} +module Moonlight.Pale.Ghc.ModuleSurface + ( ParsedModuleName, + mkParsedModuleName, + unParsedModuleName, + ParsedName, + mkParsedName, + unParsedName, + ModuleSurface (..), + ModuleSurfaceError (..), + ExportSpec (..), + ExportItem (..), + ExportChildSpec (..), + explicitExportNames, + GhcParseFailure (..), + renderGhcParseFailure, + parseWithGhcParser, + parseHsModule, + moduleIdentity, + moduleImportNames, + moduleExportNames, + moduleExportIdentifiers, + exportedIdentifier, + wrappedNameIdentifier, + rdrNameIdentifier, + moduleSurfaceFromGhcPs, + ) +where + +import Data.Kind (Type) +import Data.Function ((&)) +import Data.List (find) +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.FastString (mkFastString) +import GHC.Data.StringBuffer (StringBuffer, stringToStringBuffer) +import GHC.Driver.DynFlags (Language (..), languageExtensions) +import GHC.Driver.Flags (OnOff (..), WarningFlag, impliedXFlags) +import GHC.Driver.Session (flagSpecFlag, flagSpecName, xFlags) +import GHC.Hs + ( GhcPs, + HsModule (..), + IE (..), + IEWildcard (..), + IEWrappedName (..), + ImportDecl (..), + LIE, + LIEWrappedName, + ) +import GHC.LanguageExtensions.Type (Extension) +import GHC.Parser (parseModule) +import GHC.Parser.Errors.Ppr () +import GHC.Parser.Header (getOptions) +import GHC.Parser.Lexer + ( P (..), + ParseResult (..), + PState, + getPsErrorMessages, + initParserState, + mkParserOpts, + ) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Name.Reader (RdrName, rdrNameOcc) +import GHC.Types.SrcLoc (GenLocated, mkRealSrcLoc, unLoc) +import GHC.Types.Error (defaultOpts, isEmptyMessages) +import GHC.Unit.Module.Warnings (emptyWarningCategorySet) +import GHC.Utils.Error + ( DiagOpts (..), + pprMessages, + ) +import GHC.Utils.Outputable (defaultSDocContext, showSDocUnsafe) +import Language.Haskell.Syntax.Module.Name (moduleNameString) +import Moonlight.Core (IdentifierToken, mkIdentifierTokenWith, renderIdentifierToken) +import Moonlight.Core (isCompactName, isQualifiedModuleName) + +type ParsedModuleNameNamespace :: Type +data ParsedModuleNameNamespace + +type ParsedModuleName :: Type +newtype ParsedModuleName = ParsedModuleName (IdentifierToken ParsedModuleNameNamespace) + deriving stock (Eq, Ord, Show) + +type ParsedNameNamespace :: Type +data ParsedNameNamespace + +type ParsedName :: Type +newtype ParsedName = ParsedName (IdentifierToken ParsedNameNamespace) + deriving stock (Eq, Ord, Show) + +type ModuleSurface :: Type +data ModuleSurface = ModuleSurface + { surfaceModuleName :: Maybe ParsedModuleName, + surfaceImportedModules :: Set ParsedModuleName, + surfaceExports :: !ExportSpec + } + deriving stock (Eq, Show) + +type ExportSpec :: Type +data ExportSpec + = ImplicitExports + | ExplicitExports ![ExportItem] + deriving stock (Eq, Ord, Show) + +type ExportItem :: Type +data ExportItem + = ExportValue !ParsedName + | ExportType !ParsedName !ExportChildSpec + | ExportPattern !ParsedName + | ExportModule !ParsedModuleName + deriving stock (Eq, Ord, Show) + +type ExportChildSpec :: Type +data ExportChildSpec + = NoExportedChildren + | AllExportedChildren + | ExplicitExportedChildren ![ParsedName] + deriving stock (Eq, Ord, Show) + +type ModuleSurfaceError :: Type +data ModuleSurfaceError + = InvalidSurfaceModuleName !String + | InvalidImportedModuleName !String + | InvalidExportedName !String + | InvalidReexportedModuleName !String + deriving stock (Eq, Ord, Show) + +type GhcParseFailure :: Type +data GhcParseFailure + = LanguagePragmaHeaderRejected !FilePath !String + | SourceParseRejected !FilePath !String + deriving stock (Eq, Ord, Show) + +renderGhcParseFailure :: GhcParseFailure -> String +renderGhcParseFailure = \case + LanguagePragmaHeaderRejected sourcePath rendered -> + sourcePath <> ": malformed LANGUAGE/OPTIONS_GHC header\n" <> rendered + SourceParseRejected sourcePath rendered -> + sourcePath <> ": parse failure\n" <> rendered + +mkParsedModuleName :: String -> Maybe ParsedModuleName +mkParsedModuleName = + fmap ParsedModuleName . mkIdentifierTokenWith isQualifiedModuleName . Text.pack + +unParsedModuleName :: ParsedModuleName -> String +unParsedModuleName (ParsedModuleName identifierToken) = + Text.unpack (renderIdentifierToken identifierToken) + +mkParsedName :: String -> Maybe ParsedName +mkParsedName = + fmap ParsedName . mkIdentifierTokenWith isCompactName . Text.pack + +unParsedName :: ParsedName -> String +unParsedName (ParsedName identifierToken) = + Text.unpack (renderIdentifierToken identifierToken) + +parseHsModule :: FilePath -> String -> Either GhcParseFailure (HsModule GhcPs) +parseHsModule sourcePath moduleContents = + unLoc <$> parseWithGhcParser sourcePath moduleContents parseModule + +parseWithGhcParser :: FilePath -> String -> P a -> Either GhcParseFailure a +parseWithGhcParser sourcePath sourceContents parser = do + enabledExtensions <- parserExtensions sourcePath sourceBuffer + let parserState = + initParserState + (mkParserOpts enabledExtensions parserDiagOpts False False False False) + sourceBuffer + (mkRealSrcLoc (mkFastString sourcePath) 1 1) + case unP parser parserState of + POk _ parsedValue -> Right parsedValue + PFailed parserStateValue -> + Left (SourceParseRejected sourcePath (renderParseFailure parserStateValue)) + where + sourceBuffer = stringToStringBuffer sourceContents + +moduleIdentity :: HsModule GhcPs -> Either ModuleSurfaceError (Maybe String) +moduleIdentity = + fmap (fmap unParsedModuleName . surfaceModuleName) + . moduleSurfaceFromGhcPs + +moduleImportNames :: HsModule GhcPs -> Either ModuleSurfaceError (Set String) +moduleImportNames = + fmap (Set.map unParsedModuleName . surfaceImportedModules) + . moduleSurfaceFromGhcPs + +moduleExportNames :: HsModule GhcPs -> Either ModuleSurfaceError (Maybe (Set String)) +moduleExportNames = + fmap + (fmap (Set.map unParsedName) . explicitExportNames . surfaceExports) + . moduleSurfaceFromGhcPs + +moduleExportIdentifiers :: Maybe (GenLocated l [LIE GhcPs]) -> Either ModuleSurfaceError (Maybe (Set String)) +moduleExportIdentifiers maybeExports = + case maybeExports of + Nothing -> Right Nothing + Just exports -> + Just . Set.fromList + <$> traverse exportedIdentifier (unLoc exports) + +moduleSurfaceFromGhcPs :: HsModule GhcPs -> Either ModuleSurfaceError ModuleSurface +moduleSurfaceFromGhcPs moduleAst = + ModuleSurface + <$> traverse checkedSurfaceModuleName (moduleNameString . unLoc <$> hsmodName moduleAst) + <*> (Set.fromList <$> traverse checkedImportedModuleName importedNames) + <*> traverseExportSpec (hsmodExports moduleAst) + where + importedNames = + fmap (moduleNameString . unLoc . ideclName . unLoc) (hsmodImports moduleAst) + + checkedSurfaceModuleName rawName = + maybe (Left (InvalidSurfaceModuleName rawName)) Right (mkParsedModuleName rawName) + + checkedImportedModuleName rawName = + maybe (Left (InvalidImportedModuleName rawName)) Right (mkParsedModuleName rawName) + +traverseExportSpec :: Maybe (GenLocated l [LIE GhcPs]) -> Either ModuleSurfaceError ExportSpec +traverseExportSpec = + maybe + (Right ImplicitExports) + (fmap ExplicitExports . traverse exportItem . unLoc) + +exportedIdentifier :: LIE GhcPs -> Either ModuleSurfaceError String +exportedIdentifier = + fmap exportItemIdentifier . exportItem + +exportItem :: LIE GhcPs -> Either ModuleSurfaceError ExportItem +exportItem exportEntry = + case unLoc exportEntry of + IEVar _ wrappedNameValue _ -> + exportWrappedName wrappedNameValue + IEThingAbs _ wrappedNameValue _ -> + ExportType <$> checkedWrappedName wrappedNameValue <*> pure NoExportedChildren + IEThingAll _ wrappedNameValue _ -> + ExportType <$> checkedWrappedName wrappedNameValue <*> pure AllExportedChildren + IEThingWith _ wrappedNameValue wildcardValue childNames _ -> + ExportType + <$> checkedWrappedName wrappedNameValue + <*> case wildcardValue of + NoIEWildcard -> + ExplicitExportedChildren <$> traverse checkedWrappedName childNames + IEWildcard _ -> + pure AllExportedChildren + IEModuleContents _ moduleName -> + let rawName = moduleNameString (unLoc moduleName) + in maybe + (Left (InvalidReexportedModuleName rawName)) + (Right . ExportModule) + (mkParsedModuleName rawName) + IEGroup {} -> + Left (InvalidExportedName "") + IEDoc {} -> + Left (InvalidExportedName "") + IEDocNamed {} -> + Left (InvalidExportedName "") + +exportWrappedName :: LIEWrappedName GhcPs -> Either ModuleSurfaceError ExportItem +exportWrappedName wrappedNameValue = + case unLoc wrappedNameValue of + IEPattern {} -> ExportPattern <$> checkedWrappedName wrappedNameValue + IEType {} -> ExportType <$> checkedWrappedName wrappedNameValue <*> pure NoExportedChildren + IEData {} -> ExportType <$> checkedWrappedName wrappedNameValue <*> pure NoExportedChildren + _ -> ExportValue <$> checkedWrappedName wrappedNameValue + +wrappedNameIdentifier :: LIEWrappedName GhcPs -> Either ModuleSurfaceError String +wrappedNameIdentifier = + fmap unParsedName . checkedWrappedName + +checkedWrappedName :: LIEWrappedName GhcPs -> Either ModuleSurfaceError ParsedName +checkedWrappedName wrappedNameValue = + maybe + (Left (InvalidExportedName rawName)) + Right + (mkParsedName rawName) + where + rawName = rdrNameIdentifier (unLoc wrappedLocatedName) + wrappedLocatedName = + case unLoc wrappedNameValue of + IEName _ name -> name + IEPattern _ name -> name + IEType _ name -> name + IEDefault _ name -> name + IEData _ name -> name + +explicitExportNames :: ExportSpec -> Maybe (Set ParsedName) +explicitExportNames = \case + ImplicitExports -> + Nothing + ExplicitExports exportItems -> + Just (Set.fromList (foldMap exportItemNames exportItems)) + +exportItemNames :: ExportItem -> [ParsedName] +exportItemNames = \case + ExportValue parsedName -> [parsedName] + ExportType parsedName childSpec -> parsedName : childNames childSpec + ExportPattern parsedName -> [parsedName] + ExportModule _ -> [] + where + childNames = \case + ExplicitExportedChildren names -> names + NoExportedChildren -> [] + AllExportedChildren -> [] + +exportItemIdentifier :: ExportItem -> String +exportItemIdentifier = \case + ExportValue parsedName -> unParsedName parsedName + ExportType parsedName _ -> unParsedName parsedName + ExportPattern parsedName -> unParsedName parsedName + ExportModule parsedModuleName -> unParsedModuleName parsedModuleName + +rdrNameIdentifier :: RdrName -> String +rdrNameIdentifier = + occNameString . rdrNameOcc + +renderParseFailure :: PState -> String +renderParseFailure parserStateValue = + parserStateValue + & getPsErrorMessages + & pprMessages defaultOpts + & showSDocUnsafe + +type LanguagePragmaDirective :: Type +data LanguagePragmaDirective + = UseLanguage !Language + | EnableExtension !Extension + | DisableExtension !Extension + deriving stock (Eq, Show) + +type ParserExtensionState :: Type +data ParserExtensionState = ParserExtensionState + { pesEnabled :: !(EnumSet.EnumSet Extension), + pesExplicitlyDisabled :: !(EnumSet.EnumSet Extension) + } + +parserExtensions :: + FilePath -> + StringBuffer -> + Either GhcParseFailure (EnumSet.EnumSet Extension) +parserExtensions sourcePath sourceBuffer = + let headerParserOptions = + mkParserOpts + (pesEnabled ghc2024ParserExtensionState) + parserDiagOpts + False + False + False + False + (headerMessages, locatedOptions) = + getOptions + headerParserOptions + supportedLanguagePragmas + sourceBuffer + sourcePath + in if isEmptyMessages headerMessages + then + Right + ( pesEnabled + ( foldl' + applyLanguagePragmaDirective + ghc2024ParserExtensionState + (mapMaybe (languagePragmaDirective . unLoc) locatedOptions) + ) + ) + else + Left + ( LanguagePragmaHeaderRejected + sourcePath + (showSDocUnsafe (pprMessages defaultOpts headerMessages)) + ) + +parserExtensionStateForLanguage :: Language -> ParserExtensionState +parserExtensionStateForLanguage languageValue = + closeImpliedExtensions + ParserExtensionState + { pesEnabled = EnumSet.fromList (languageExtensions (Just languageValue)), + pesExplicitlyDisabled = EnumSet.empty + } + +ghc2024ParserExtensionState :: ParserExtensionState +ghc2024ParserExtensionState = + parserExtensionStateForLanguage GHC2024 + +applyLanguagePragmaDirective :: ParserExtensionState -> LanguagePragmaDirective -> ParserExtensionState +applyLanguagePragmaDirective _ (UseLanguage languageValue) = + parserExtensionStateForLanguage languageValue +applyLanguagePragmaDirective parserExtensionState (EnableExtension extensionValue) = + closeImpliedExtensions + parserExtensionState + { pesEnabled = EnumSet.insert extensionValue (pesEnabled parserExtensionState), + pesExplicitlyDisabled = EnumSet.delete extensionValue (pesExplicitlyDisabled parserExtensionState) + } +applyLanguagePragmaDirective parserExtensionState (DisableExtension extensionValue) = + closeImpliedExtensions + parserExtensionState + { pesEnabled = EnumSet.delete extensionValue (pesEnabled parserExtensionState), + pesExplicitlyDisabled = EnumSet.insert extensionValue (pesExplicitlyDisabled parserExtensionState) + } + +closeImpliedExtensions :: ParserExtensionState -> ParserExtensionState +closeImpliedExtensions parserExtensionState = + let nextState = + foldl' + applyImpliedExtension + parserExtensionState + impliedXFlags + in if sameParserExtensionState nextState parserExtensionState + then parserExtensionState + else closeImpliedExtensions nextState + +sameParserExtensionState :: ParserExtensionState -> ParserExtensionState -> Bool +sameParserExtensionState leftState rightState = + EnumSet.toList (pesEnabled leftState) == EnumSet.toList (pesEnabled rightState) + && EnumSet.toList (pesExplicitlyDisabled leftState) == EnumSet.toList (pesExplicitlyDisabled rightState) + +applyImpliedExtension :: ParserExtensionState -> (Extension, OnOff Extension) -> ParserExtensionState +applyImpliedExtension parserExtensionState (triggerExtension, impliedDirective) + | EnumSet.member triggerExtension (pesEnabled parserExtensionState) = + applyImpliedDirective parserExtensionState impliedDirective + | otherwise = + parserExtensionState + +applyImpliedDirective :: ParserExtensionState -> OnOff Extension -> ParserExtensionState +applyImpliedDirective parserExtensionState (On extensionValue) + | EnumSet.member extensionValue (pesExplicitlyDisabled parserExtensionState) = + parserExtensionState + | otherwise = + parserExtensionState + { pesEnabled = EnumSet.insert extensionValue (pesEnabled parserExtensionState) + } +applyImpliedDirective parserExtensionState (Off extensionValue) = + parserExtensionState + { pesEnabled = EnumSet.delete extensionValue (pesEnabled parserExtensionState) + } + +languagePragmaDirective :: String -> Maybe LanguagePragmaDirective +languagePragmaDirective optionToken = + Text.stripPrefix (Text.pack "-X") (Text.pack optionToken) + >>= directiveForName . Text.unpack + where + directiveForName token = + case languageName token of + Just languageValue -> + Just (UseLanguage languageValue) + Nothing -> + case extensionNamed token of + Just extensionValue -> + Just (EnableExtension extensionValue) + Nothing -> + DisableExtension <$> noExtension token + +languageName :: String -> Maybe Language +languageName token = + find + ((== token) . show) + ([minBound .. maxBound] :: [Language]) + +noExtension :: String -> Maybe Extension +noExtension token = + case Text.stripPrefix (Text.pack "No") (Text.pack token) of + Nothing -> Nothing + Just extensionName -> extensionNamed (Text.unpack extensionName) + +extensionNamed :: String -> Maybe Extension +extensionNamed extensionName = + flagSpecFlag + <$> find + ((== extensionName) . flagSpecName) + xFlags + +supportedLanguagePragmas :: [String] +supportedLanguagePragmas = + languageNames + <> extensionNames + <> fmap ("No" <>) extensionNames + where + languageNames = + fmap show ([minBound .. maxBound] :: [Language]) + extensionNames = + fmap flagSpecName xFlags + +parserDiagOpts :: DiagOpts +parserDiagOpts = + DiagOpts + { diag_warning_flags = EnumSet.empty :: EnumSet.EnumSet WarningFlag, + diag_fatal_warning_flags = EnumSet.empty :: EnumSet.EnumSet WarningFlag, + diag_custom_warning_categories = emptyWarningCategorySet, + diag_fatal_custom_warning_categories = emptyWarningCategorySet, + diag_warn_is_error = False, + diag_reverse_errors = False, + diag_max_errors = Nothing, + diag_ppr_ctx = defaultSDocContext + } diff --git a/src-test-laws/Moonlight/Pale/Test/Laws/Algebraic.hs b/src-test-laws/Moonlight/Pale/Test/Laws/Algebraic.hs new file mode 100644 --- /dev/null +++ b/src-test-laws/Moonlight/Pale/Test/Laws/Algebraic.hs @@ -0,0 +1,195 @@ +{-| Predicates for algebraic, lattice, module, and action laws. -} +module Moonlight.Pale.Test.Laws.Algebraic + ( monoidAssociativity, + monoidLeftIdentity, + monoidRightIdentity, + groupLeftInverse, + groupRightInverse, + abelianCommutativity, + semigroupAssociativity, + ringAdditiveAssociativity, + ringAdditiveCommutativity, + ringAdditiveLeftIdentity, + ringAdditiveRightIdentity, + ringAdditiveLeftInverse, + ringAdditiveRightInverse, + ringMultiplicativeAssociativity, + ringMultiplicativeLeftIdentity, + ringMultiplicativeRightIdentity, + ringDistributivityLeft, + ringDistributivityRight, + ringMultiplicativeCommutativity, + latticeAbsorptionJoin, + latticeAbsorptionMeet, + latticeIdempotenceJoin, + latticeIdempotenceMeet, + latticeAssociativityJoin, + latticeAssociativityMeet, + latticeCommutativityJoin, + latticeCommutativityMeet, + distributiveLatticeJoinOverMeet, + distributiveLatticeMeetOverJoin, + booleanAlgebraComplementJoin, + booleanAlgebraComplementMeet, + idempotentLaw, + moduleDistributivityScalar, + moduleDistributivityVector, + moduleCompatibility, + moduleIdentity, + actionAssociativity, + actionIdentity, + ) +where + +import Moonlight.Core (AdditiveGroup (..), AdditiveMonoid (..), MultiplicativeMonoid (..), Ring) + +monoidAssociativity :: Eq a => (a -> a -> a) -> a -> a -> a -> Bool +monoidAssociativity op x y z = op (op x y) z == op x (op y z) + +monoidLeftIdentity :: Eq a => (a -> a -> a) -> a -> a -> Bool +monoidLeftIdentity op e x = op e x == x + +monoidRightIdentity :: Eq a => (a -> a -> a) -> a -> a -> Bool +monoidRightIdentity op e x = op x e == x + +groupLeftInverse :: Eq a => (a -> a -> a) -> (a -> a) -> a -> a -> Bool +groupLeftInverse op inv e x = op (inv x) x == e + +groupRightInverse :: Eq a => (a -> a -> a) -> (a -> a) -> a -> a -> Bool +groupRightInverse op inv e x = op x (inv x) == e + +abelianCommutativity :: Eq a => (a -> a -> a) -> a -> a -> Bool +abelianCommutativity op x y = op x y == op y x + +semigroupAssociativity :: Eq a => (a -> a -> a) -> a -> a -> a -> Bool +semigroupAssociativity = monoidAssociativity + +ringAdditiveAssociativity :: (Eq a, AdditiveGroup a) => a -> a -> a -> Bool +ringAdditiveAssociativity x y z = add (add x y) z == add x (add y z) + +ringAdditiveCommutativity :: (Eq a, AdditiveGroup a) => a -> a -> Bool +ringAdditiveCommutativity x y = add x y == add y x + +ringAdditiveLeftIdentity :: (Eq a, AdditiveGroup a) => a -> Bool +ringAdditiveLeftIdentity x = add zero x == x + +ringAdditiveRightIdentity :: (Eq a, AdditiveGroup a) => a -> Bool +ringAdditiveRightIdentity x = add x zero == x + +ringAdditiveLeftInverse :: (Eq a, AdditiveGroup a) => a -> Bool +ringAdditiveLeftInverse x = add (neg x) x == zero + +ringAdditiveRightInverse :: (Eq a, AdditiveGroup a) => a -> Bool +ringAdditiveRightInverse x = add x (neg x) == zero + +ringMultiplicativeAssociativity :: (Eq a, MultiplicativeMonoid a) => a -> a -> a -> Bool +ringMultiplicativeAssociativity x y z = mul (mul x y) z == mul x (mul y z) + +ringMultiplicativeLeftIdentity :: (Eq a, MultiplicativeMonoid a) => a -> Bool +ringMultiplicativeLeftIdentity x = mul one x == x + +ringMultiplicativeRightIdentity :: (Eq a, MultiplicativeMonoid a) => a -> Bool +ringMultiplicativeRightIdentity x = mul x one == x + +ringDistributivityLeft :: (Eq a, Ring a) => a -> a -> a -> Bool +ringDistributivityLeft x y z = mul x (add y z) == add (mul x y) (mul x z) + +ringDistributivityRight :: (Eq a, Ring a) => a -> a -> a -> Bool +ringDistributivityRight x y z = mul (add x y) z == add (mul x z) (mul y z) + +ringMultiplicativeCommutativity :: (Eq a, MultiplicativeMonoid a) => a -> a -> Bool +ringMultiplicativeCommutativity x y = mul x y == mul y x + +latticeAbsorptionJoin :: Eq a => (a -> a -> a) -> (a -> a -> a) -> a -> a -> Bool +latticeAbsorptionJoin ljoin lmeet x y = ljoin x (lmeet x y) == x + +latticeAbsorptionMeet :: Eq a => (a -> a -> a) -> (a -> a -> a) -> a -> a -> Bool +latticeAbsorptionMeet ljoin lmeet x y = lmeet x (ljoin x y) == x + +latticeIdempotenceJoin :: Eq a => (a -> a -> a) -> a -> Bool +latticeIdempotenceJoin ljoin x = ljoin x x == x + +latticeIdempotenceMeet :: Eq a => (a -> a -> a) -> a -> Bool +latticeIdempotenceMeet lmeet x = lmeet x x == x + +latticeAssociativityJoin :: Eq a => (a -> a -> a) -> a -> a -> a -> Bool +latticeAssociativityJoin ljoin x y z = ljoin (ljoin x y) z == ljoin x (ljoin y z) + +latticeAssociativityMeet :: Eq a => (a -> a -> a) -> a -> a -> a -> Bool +latticeAssociativityMeet lmeet x y z = lmeet (lmeet x y) z == lmeet x (lmeet y z) + +latticeCommutativityJoin :: Eq a => (a -> a -> a) -> a -> a -> Bool +latticeCommutativityJoin ljoin x y = ljoin x y == ljoin y x + +latticeCommutativityMeet :: Eq a => (a -> a -> a) -> a -> a -> Bool +latticeCommutativityMeet lmeet x y = lmeet x y == lmeet y x + +distributiveLatticeJoinOverMeet :: Eq a => (a -> a -> a) -> (a -> a -> a) -> a -> a -> a -> Bool +distributiveLatticeJoinOverMeet ljoin lmeet x y z = + ljoin x (lmeet y z) == lmeet (ljoin x y) (ljoin x z) + +distributiveLatticeMeetOverJoin :: Eq a => (a -> a -> a) -> (a -> a -> a) -> a -> a -> a -> Bool +distributiveLatticeMeetOverJoin ljoin lmeet x y z = + lmeet x (ljoin y z) == ljoin (lmeet x y) (lmeet x z) + +booleanAlgebraComplementJoin :: Eq a => (a -> a -> a) -> (a -> a) -> a -> a -> Bool +booleanAlgebraComplementJoin ljoin compl topElement x = + ljoin x (compl x) == topElement + +booleanAlgebraComplementMeet :: Eq a => (a -> a -> a) -> (a -> a) -> a -> a -> Bool +booleanAlgebraComplementMeet lmeet compl bottomElement x = + lmeet x (compl x) == bottomElement + +idempotentLaw :: Eq a => (a -> a) -> a -> Bool +idempotentLaw f x = f (f x) == f x + +moduleDistributivityScalar :: + (Eq m) => + (r -> r -> r) -> + (m -> m -> m) -> + (r -> m -> m) -> + r -> + r -> + m -> + Bool +moduleDistributivityScalar rAdd mAdd mScale r s x = + mScale (rAdd r s) x == mAdd (mScale r x) (mScale s x) + +moduleDistributivityVector :: + (Eq m) => + (m -> m -> m) -> + (r -> m -> m) -> + r -> + m -> + m -> + Bool +moduleDistributivityVector mAdd mScale r x y = + mScale r (mAdd x y) == mAdd (mScale r x) (mScale r y) + +moduleCompatibility :: + (Eq m) => + (r -> r -> r) -> + (r -> m -> m) -> + r -> + r -> + m -> + Bool +moduleCompatibility rMul mScale r s x = + mScale (rMul r s) x == mScale r (mScale s x) + +moduleIdentity :: (Eq m) => r -> (r -> m -> m) -> m -> Bool +moduleIdentity rOne mScale x = mScale rOne x == x + +actionAssociativity :: + (Eq s) => + (m -> m -> m) -> + (m -> s -> s) -> + m -> + m -> + s -> + Bool +actionAssociativity mOp mAct g h x = + mAct (mOp g h) x == mAct g (mAct h x) + +actionIdentity :: (Eq s) => m -> (m -> s -> s) -> s -> Bool +actionIdentity e mAct x = mAct e x == x diff --git a/src-test-laws/Moonlight/Pale/Test/Laws/Lattice.hs b/src-test-laws/Moonlight/Pale/Test/Laws/Lattice.hs new file mode 100644 --- /dev/null +++ b/src-test-laws/Moonlight/Pale/Test/Laws/Lattice.hs @@ -0,0 +1,465 @@ +{-| Checked finite-lattice compilation and generated law suites. -} +module Moonlight.Pale.Test.Laws.Lattice + ( FiniteLattice, + LatticeBounds (..), + FiniteLatticeError (..), + FiniteLatticeLookupError (..), + compileFiniteLattice, + finiteLatticeJoin, + finiteLatticeMeet, + finiteLatticeLaws, + ) +where + +import Data.Foldable (traverse_) +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 Data.Vector (Vector) +import Data.Vector qualified as Vector +import Moonlight.Pale.Test.Laws.Suite (LawSuite, hUnitLaw, lawGroup) +import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure) + +type FiniteLattice :: Type -> Type +data FiniteLattice a = FiniteLattice + { finiteLatticeName :: String, + finiteLatticeValues :: !(Vector a), + finiteLatticeIndex :: !(Map a Int), + finiteLatticeJoinTable :: !(Vector Int), + finiteLatticeMeetTable :: !(Vector Int), + finiteLatticeBounds :: !(Maybe DenseLatticeBounds) + } + +type LatticeBounds :: Type -> Type +data LatticeBounds a = LatticeBounds + { latticeBottom :: a, + latticeTop :: a + } + deriving stock (Eq, Show) + +data DenseLatticeBounds = DenseLatticeBounds + { denseLatticeBottom :: !Int, + denseLatticeTop :: !Int + } + +type FiniteLatticeError :: Type -> Type +data FiniteLatticeError a + = DuplicateUniverseElement a !Int !Int + | BottomOutsideUniverse a + | TopOutsideUniverse a + | JoinOutsideUniverse a a a + | MeetOutsideUniverse a a a + deriving stock (Eq, Show) + +type FiniteLatticeLookupError :: Type -> Type +data FiniteLatticeLookupError a + = UnknownFiniteLatticeElement a + | FiniteLatticeTableIndexOutOfBounds !Int + | FiniteLatticeValueIndexOutOfBounds !Int + deriving stock (Eq, Show) + +data UniverseIndexCompilation a = UniverseIndexCompilation + { compiledUniverseIndex :: !(Map a Int), + universeIndexErrorsReversed :: ![FiniteLatticeError a] + } + +data DenseTableCompilation a = DenseTableCompilation + { joinIndicesReversed :: ![Int], + meetIndicesReversed :: ![Int], + tableErrorsReversed :: ![FiniteLatticeError a] + } + +compileFiniteLattice :: + Ord a => + String -> + NonEmpty a -> + (a -> a -> a) -> + (a -> a -> a) -> + Maybe (LatticeBounds a) -> + Either (NonEmpty (FiniteLatticeError a)) (FiniteLattice a) +compileFiniteLattice name universe joinOperation meetOperation bounds = do + let values = Vector.fromList (NonEmpty.toList universe) + valueIndex <- compileUniverseIndex values + let (denseBounds, boundsErrors) = compileBounds valueIndex bounds + tableCompilation = + compileDenseTables valueIndex values joinOperation meetOperation + compilationErrors = + boundsErrors <> reverse (tableErrorsReversed tableCompilation) + case NonEmpty.nonEmpty compilationErrors of + Just errors -> Left errors + Nothing -> + Right + FiniteLattice + { finiteLatticeName = name, + finiteLatticeValues = values, + finiteLatticeIndex = valueIndex, + finiteLatticeJoinTable = + Vector.fromList (reverse (joinIndicesReversed tableCompilation)), + finiteLatticeMeetTable = + Vector.fromList (reverse (meetIndicesReversed tableCompilation)), + finiteLatticeBounds = denseBounds + } + +compileUniverseIndex :: + Ord a => + Vector a -> + Either (NonEmpty (FiniteLatticeError a)) (Map a Int) +compileUniverseIndex values = + let compilation = + Vector.ifoldl' + insertUniverseElement + (UniverseIndexCompilation Map.empty []) + values + in case NonEmpty.nonEmpty (reverse (universeIndexErrorsReversed compilation)) of + Just errors -> Left errors + Nothing -> Right (compiledUniverseIndex compilation) + +insertUniverseElement :: + Ord a => + UniverseIndexCompilation a -> + Int -> + a -> + UniverseIndexCompilation a +insertUniverseElement compilation duplicatePosition value = + case Map.lookup value (compiledUniverseIndex compilation) of + Just originalPosition -> + compilation + { universeIndexErrorsReversed = + DuplicateUniverseElement value originalPosition duplicatePosition + : universeIndexErrorsReversed compilation + } + Nothing -> + compilation + { compiledUniverseIndex = + Map.insert value duplicatePosition (compiledUniverseIndex compilation) + } + +compileBounds :: + Ord a => + Map a Int -> + Maybe (LatticeBounds a) -> + (Maybe DenseLatticeBounds, [FiniteLatticeError a]) +compileBounds _ Nothing = (Nothing, []) +compileBounds valueIndex (Just bounds) = + case + ( Map.lookup (latticeBottom bounds) valueIndex, + Map.lookup (latticeTop bounds) valueIndex + ) + of + (Just bottomIndex, Just topIndex) -> + (Just (DenseLatticeBounds bottomIndex topIndex), []) + (Nothing, Just _) -> + (Nothing, [BottomOutsideUniverse (latticeBottom bounds)]) + (Just _, Nothing) -> + (Nothing, [TopOutsideUniverse (latticeTop bounds)]) + (Nothing, Nothing) -> + ( Nothing, + [ BottomOutsideUniverse (latticeBottom bounds), + TopOutsideUniverse (latticeTop bounds) + ] + ) + +compileDenseTables :: + Ord a => + Map a Int -> + Vector a -> + (a -> a -> a) -> + (a -> a -> a) -> + DenseTableCompilation a +compileDenseTables valueIndex values joinOperation meetOperation = + Vector.foldl' + (\compilation leftValue -> + Vector.foldl' + (compileOperationPair valueIndex joinOperation meetOperation leftValue) + compilation + values + ) + (DenseTableCompilation [] [] []) + values + +compileOperationPair :: + Ord a => + Map a Int -> + (a -> a -> a) -> + (a -> a -> a) -> + a -> + DenseTableCompilation a -> + a -> + DenseTableCompilation a +compileOperationPair valueIndex joinOperation meetOperation leftValue compilation rightValue = + let !joinResult = joinOperation leftValue rightValue + !meetResult = meetOperation leftValue rightValue + !joinIndex = Map.lookup joinResult valueIndex + !meetIndex = Map.lookup meetResult valueIndex + closureErrors = + case (joinIndex, meetIndex) of + (Nothing, Nothing) -> + [ JoinOutsideUniverse leftValue rightValue joinResult, + MeetOutsideUniverse leftValue rightValue meetResult + ] + (Nothing, Just _) -> + [JoinOutsideUniverse leftValue rightValue joinResult] + (Just _, Nothing) -> + [MeetOutsideUniverse leftValue rightValue meetResult] + (Just _, Just _) -> [] + in DenseTableCompilation + { joinIndicesReversed = + maybe + (joinIndicesReversed compilation) + (: joinIndicesReversed compilation) + joinIndex, + meetIndicesReversed = + maybe + (meetIndicesReversed compilation) + (: meetIndicesReversed compilation) + meetIndex, + tableErrorsReversed = + reverse closureErrors <> tableErrorsReversed compilation + } + +finiteLatticeJoin :: + Ord a => + FiniteLattice a -> + a -> + a -> + Either (FiniteLatticeLookupError a) a +finiteLatticeJoin lattice = + evaluateFiniteLatticeOperation (finiteLatticeJoinTable lattice) lattice + +finiteLatticeMeet :: + Ord a => + FiniteLattice a -> + a -> + a -> + Either (FiniteLatticeLookupError a) a +finiteLatticeMeet lattice = + evaluateFiniteLatticeOperation (finiteLatticeMeetTable lattice) lattice + +evaluateFiniteLatticeOperation :: + Ord a => + Vector Int -> + FiniteLattice a -> + a -> + a -> + Either (FiniteLatticeLookupError a) a +evaluateFiniteLatticeOperation table lattice leftValue rightValue = do + leftIndex <- lookupFiniteLatticeElement lattice leftValue + rightIndex <- lookupFiniteLatticeElement lattice rightValue + resultIndex <- denseOperationResult lattice table leftIndex rightIndex + denseLatticeValue lattice resultIndex + +lookupFiniteLatticeElement :: + Ord a => + FiniteLattice a -> + a -> + Either (FiniteLatticeLookupError a) Int +lookupFiniteLatticeElement lattice value = + case Map.lookup value (finiteLatticeIndex lattice) of + Nothing -> Left (UnknownFiniteLatticeElement value) + Just denseIndex -> Right denseIndex + +denseLatticeValue :: + FiniteLattice a -> + Int -> + Either (FiniteLatticeLookupError a) a +denseLatticeValue lattice denseIndex = + case finiteLatticeValues lattice Vector.!? denseIndex of + Nothing -> Left (FiniteLatticeValueIndexOutOfBounds denseIndex) + Just value -> Right value + +denseOperationResult :: + FiniteLattice a -> + Vector Int -> + Int -> + Int -> + Either (FiniteLatticeLookupError a) Int +denseOperationResult lattice table leftIndex rightIndex = + let cardinality = Vector.length (finiteLatticeValues lattice) + tableIndex = leftIndex * cardinality + rightIndex + in case table Vector.!? tableIndex of + Nothing -> Left (FiniteLatticeTableIndexOutOfBounds tableIndex) + Just resultIndex -> Right resultIndex + +finiteLatticeLaws :: Show a => FiniteLattice a -> [LawSuite] +finiteLatticeLaws lattice = + [ lawGroup + (finiteLatticeName lattice <> " lattice laws") + ( [ joinCommutativity lattice, + meetCommutativity lattice, + joinAssociativity lattice, + meetAssociativity lattice, + joinAbsorption lattice, + meetAbsorption lattice, + joinIdempotence lattice, + meetIdempotence lattice + ] + <> boundedLaws lattice + ) + ] + +joinCommutativity :: Show a => FiniteLattice a -> LawSuite +joinCommutativity lattice = + universalPairLaw lattice "join is commutative" $ \leftIndex leftValue rightIndex rightValue -> + assertDenseEquation + ("join operands " <> show (leftValue, rightValue)) + (denseOperationResult lattice (finiteLatticeJoinTable lattice) leftIndex rightIndex) + (denseOperationResult lattice (finiteLatticeJoinTable lattice) rightIndex leftIndex) + +meetCommutativity :: Show a => FiniteLattice a -> LawSuite +meetCommutativity lattice = + universalPairLaw lattice "meet is commutative" $ \leftIndex leftValue rightIndex rightValue -> + assertDenseEquation + ("meet operands " <> show (leftValue, rightValue)) + (denseOperationResult lattice (finiteLatticeMeetTable lattice) leftIndex rightIndex) + (denseOperationResult lattice (finiteLatticeMeetTable lattice) rightIndex leftIndex) + +joinAssociativity :: Show a => FiniteLattice a -> LawSuite +joinAssociativity lattice = + universalTripleLaw lattice "join is associative" $ \xIndex xValue yIndex yValue zIndex zValue -> + let joinResult = denseOperationResult lattice (finiteLatticeJoinTable lattice) + in assertDenseEquation + ("join operands " <> show (xValue, yValue, zValue)) + (joinResult xIndex yIndex >>= (`joinResult` zIndex)) + (joinResult yIndex zIndex >>= joinResult xIndex) + +meetAssociativity :: Show a => FiniteLattice a -> LawSuite +meetAssociativity lattice = + universalTripleLaw lattice "meet is associative" $ \xIndex xValue yIndex yValue zIndex zValue -> + let meetResult = denseOperationResult lattice (finiteLatticeMeetTable lattice) + in assertDenseEquation + ("meet operands " <> show (xValue, yValue, zValue)) + (meetResult xIndex yIndex >>= (`meetResult` zIndex)) + (meetResult yIndex zIndex >>= meetResult xIndex) + +joinAbsorption :: Show a => FiniteLattice a -> LawSuite +joinAbsorption lattice = + universalPairLaw lattice "absorption: join a (meet a b) = a" $ \xIndex xValue yIndex yValue -> + let joinResult = denseOperationResult lattice (finiteLatticeJoinTable lattice) + meetResult = denseOperationResult lattice (finiteLatticeMeetTable lattice) + in assertDenseEquation + ("absorption operands " <> show (xValue, yValue)) + (meetResult xIndex yIndex >>= joinResult xIndex) + (Right xIndex) + +meetAbsorption :: Show a => FiniteLattice a -> LawSuite +meetAbsorption lattice = + universalPairLaw lattice "absorption: meet a (join a b) = a" $ \xIndex xValue yIndex yValue -> + let joinResult = denseOperationResult lattice (finiteLatticeJoinTable lattice) + meetResult = denseOperationResult lattice (finiteLatticeMeetTable lattice) + in assertDenseEquation + ("absorption operands " <> show (xValue, yValue)) + (joinResult xIndex yIndex >>= meetResult xIndex) + (Right xIndex) + +joinIdempotence :: Show a => FiniteLattice a -> LawSuite +joinIdempotence lattice = + universeLaw lattice "join is idempotent" $ \denseIndex value -> + assertDenseEquation + ("join operand " <> show value) + (denseOperationResult lattice (finiteLatticeJoinTable lattice) denseIndex denseIndex) + (Right denseIndex) + +meetIdempotence :: Show a => FiniteLattice a -> LawSuite +meetIdempotence lattice = + universeLaw lattice "meet is idempotent" $ \denseIndex value -> + assertDenseEquation + ("meet operand " <> show value) + (denseOperationResult lattice (finiteLatticeMeetTable lattice) denseIndex denseIndex) + (Right denseIndex) + +boundedLaws :: Show a => FiniteLattice a -> [LawSuite] +boundedLaws lattice = + case finiteLatticeBounds lattice of + Nothing -> [] + Just bounds -> + [ universeLaw lattice "join with bottom is identity" $ \denseIndex value -> + assertDenseEquation + ("join bottom with " <> show value) + ( denseOperationResult + lattice + (finiteLatticeJoinTable lattice) + (denseLatticeBottom bounds) + denseIndex + ) + (Right denseIndex), + universeLaw lattice "meet with top is identity" $ \denseIndex value -> + assertDenseEquation + ("meet top with " <> show value) + ( denseOperationResult + lattice + (finiteLatticeMeetTable lattice) + (denseLatticeTop bounds) + denseIndex + ) + (Right denseIndex) + ] + +universeLaw :: + FiniteLattice a -> + String -> + (Int -> a -> Assertion) -> + LawSuite +universeLaw lattice label check = + hUnitLaw label $ + traverse_ + (\(denseIndex, value) -> check denseIndex value) + (Vector.indexed (finiteLatticeValues lattice)) + +universalPairLaw :: + FiniteLattice a -> + String -> + (Int -> a -> Int -> a -> Assertion) -> + LawSuite +universalPairLaw lattice label check = + hUnitLaw label $ + traverse_ + (\(leftIndex, leftValue) -> + traverse_ + (\(rightIndex, rightValue) -> + check leftIndex leftValue rightIndex rightValue + ) + indexedValues + ) + indexedValues + where + indexedValues = Vector.indexed (finiteLatticeValues lattice) + +universalTripleLaw :: + FiniteLattice a -> + String -> + (Int -> a -> Int -> a -> Int -> a -> Assertion) -> + LawSuite +universalTripleLaw lattice label check = + hUnitLaw label $ + traverse_ + (\(xIndex, xValue) -> + traverse_ + (\(yIndex, yValue) -> + traverse_ + (\(zIndex, zValue) -> + check xIndex xValue yIndex yValue zIndex zValue + ) + indexedValues + ) + indexedValues + ) + indexedValues + where + indexedValues = Vector.indexed (finiteLatticeValues lattice) + +assertDenseEquation :: + Show a => + String -> + Either (FiniteLatticeLookupError a) Int -> + Either (FiniteLatticeLookupError a) Int -> + Assertion +assertDenseEquation context leftResult rightResult = + case (leftResult, rightResult) of + (Left obstruction, _) -> + assertFailure (context <> ": left dense evaluation failed: " <> show obstruction) + (_, Left obstruction) -> + assertFailure (context <> ": right dense evaluation failed: " <> show obstruction) + (Right leftIndex, Right rightIndex) -> + assertEqual context rightIndex leftIndex diff --git a/src-test-laws/Moonlight/Pale/Test/Laws/Restriction.hs b/src-test-laws/Moonlight/Pale/Test/Laws/Restriction.hs new file mode 100644 --- /dev/null +++ b/src-test-laws/Moonlight/Pale/Test/Laws/Restriction.hs @@ -0,0 +1,372 @@ +{-| Checked finite restriction systems and their functoriality law suites. -} +module Moonlight.Pale.Test.Laws.Restriction + ( FiniteRestrictionLaw, + FiniteRestrictionError (..), + compileFiniteRestrictionLaw, + finiteRestrictionLaws, + ) +where + +import Data.Foldable (traverse_) +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet +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 Data.Vector (Vector) +import Data.Vector qualified as Vector +import Moonlight.Pale.Test.Laws.Suite (LawSuite, hUnitLaw, lawGroup) +import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure) + +type FiniteRestrictionLaw :: Type -> Type -> Type +data FiniteRestrictionLaw cell val = FiniteRestrictionLaw + { finiteRestrictionName :: String, + finiteRestrictionCells :: !(Vector cell), + finiteRestrictionUpperSets :: !(Vector IntSet), + finiteRestrictionSections :: !(Vector [val]), + finiteRestrictionMap :: cell -> cell -> val -> val + } + +type FiniteRestrictionError :: Type -> Type +data FiniteRestrictionError cell + = DuplicateRestrictionCell cell !Int !Int + | SectionCellOutsideUniverse cell + | RestrictionRelationNotReflexive cell + | RestrictionRelationNotAntisymmetric cell cell + | RestrictionRelationNotTransitive cell cell + deriving stock (Eq, Show) + +data RestrictionUniverseCompilation cell = RestrictionUniverseCompilation + { restrictionUniverseIndex :: !(Map cell Int), + restrictionUniverseErrorsReversed :: ![FiniteRestrictionError cell] + } + +data RestrictionDenseObstruction + = RestrictionCellIndexOutOfBounds !Int + | RestrictionUpperSetIndexOutOfBounds !Int + deriving stock (Eq, Show) + +compileFiniteRestrictionLaw :: + Ord cell => + String -> + NonEmpty cell -> + (cell -> cell -> Bool) -> + [(cell, val)] -> + (cell -> cell -> val -> val) -> + Either (NonEmpty (FiniteRestrictionError cell)) (FiniteRestrictionLaw cell val) +compileFiniteRestrictionLaw name cellUniverse leq sections restrict = do + let cells = Vector.fromList (NonEmpty.toList cellUniverse) + cellIndex <- compileRestrictionUniverse cells + let upperSets = compileUpperSets leq cells + validationErrors = + validateFinitePoset cells upperSets + <> unknownSectionErrors cellIndex sections + case NonEmpty.nonEmpty validationErrors of + Just errors -> Left errors + Nothing -> + Right + FiniteRestrictionLaw + { finiteRestrictionName = name, + finiteRestrictionCells = cells, + finiteRestrictionUpperSets = upperSets, + finiteRestrictionSections = compileSectionsByCell cells sections, + finiteRestrictionMap = restrict + } + +compileRestrictionUniverse :: + Ord cell => + Vector cell -> + Either (NonEmpty (FiniteRestrictionError cell)) (Map cell Int) +compileRestrictionUniverse cells = + let compilation = + Vector.ifoldl' + insertRestrictionCell + (RestrictionUniverseCompilation Map.empty []) + cells + in case NonEmpty.nonEmpty (reverse (restrictionUniverseErrorsReversed compilation)) of + Just errors -> Left errors + Nothing -> Right (restrictionUniverseIndex compilation) + +insertRestrictionCell :: + Ord cell => + RestrictionUniverseCompilation cell -> + Int -> + cell -> + RestrictionUniverseCompilation cell +insertRestrictionCell compilation duplicatePosition cell = + case Map.lookup cell (restrictionUniverseIndex compilation) of + Just originalPosition -> + compilation + { restrictionUniverseErrorsReversed = + DuplicateRestrictionCell cell originalPosition duplicatePosition + : restrictionUniverseErrorsReversed compilation + } + Nothing -> + compilation + { restrictionUniverseIndex = + Map.insert cell duplicatePosition (restrictionUniverseIndex compilation) + } + +compileUpperSets :: (cell -> cell -> Bool) -> Vector cell -> Vector IntSet +compileUpperSets leq cells = + Vector.map + (\sourceCell -> + Vector.ifoldl' + (\upperSet targetIndex targetCell -> + if leq sourceCell targetCell + then IntSet.insert targetIndex upperSet + else upperSet + ) + IntSet.empty + cells + ) + cells + +validateFinitePoset :: Vector cell -> Vector IntSet -> [FiniteRestrictionError cell] +validateFinitePoset cells upperSets = + validateReflexivity indexedRows + <> validateAntisymmetry indexedRows + <> validateTransitivity indexedRows + where + indexedRows = Vector.indexed (Vector.zip cells upperSets) + +validateReflexivity :: + Vector (Int, (cell, IntSet)) -> + [FiniteRestrictionError cell] +validateReflexivity = + Vector.foldr + (\(cellIndex, (cell, upperSet)) errors -> + if IntSet.member cellIndex upperSet + then errors + else RestrictionRelationNotReflexive cell : errors + ) + [] + +validateAntisymmetry :: + Vector (Int, (cell, IntSet)) -> + [FiniteRestrictionError cell] +validateAntisymmetry indexedRows = + reverse $ + Vector.foldl' + (\errors (leftIndex, (leftCell, leftUpperSet)) -> + Vector.foldl' + (\nestedErrors (rightIndex, (rightCell, rightUpperSet)) -> + if + leftIndex < rightIndex + && IntSet.member rightIndex leftUpperSet + && IntSet.member leftIndex rightUpperSet + then + RestrictionRelationNotAntisymmetric leftCell rightCell + : nestedErrors + else nestedErrors + ) + errors + indexedRows + ) + [] + indexedRows + +validateTransitivity :: + Vector (Int, (cell, IntSet)) -> + [FiniteRestrictionError cell] +validateTransitivity indexedRows = + reverse $ + Vector.foldl' + (\errors (_, (sourceCell, sourceUpperSet)) -> + Vector.foldl' + (\nestedErrors (middleIndex, (middleCell, middleUpperSet)) -> + if + IntSet.member middleIndex sourceUpperSet + && not (middleUpperSet `IntSet.isSubsetOf` sourceUpperSet) + then + RestrictionRelationNotTransitive sourceCell middleCell + : nestedErrors + else nestedErrors + ) + errors + indexedRows + ) + [] + indexedRows + +unknownSectionErrors :: + Ord cell => + Map cell Int -> + [(cell, val)] -> + [FiniteRestrictionError cell] +unknownSectionErrors cellIndex = + foldr + (\(cell, _) errors -> + if Map.member cell cellIndex + then errors + else SectionCellOutsideUniverse cell : errors + ) + [] + +compileSectionsByCell :: + Ord cell => + Vector cell -> + [(cell, val)] -> + Vector [val] +compileSectionsByCell cells sections = + let reversedSections = + foldl' + (\sectionsByCell (cell, value) -> + Map.insertWith (<>) cell [value] sectionsByCell + ) + Map.empty + sections + in Vector.map + (\cell -> reverse (Map.findWithDefault [] cell reversedSections)) + cells + +finiteRestrictionLaws :: + (Show cell, Show val, Eq val) => + FiniteRestrictionLaw cell val -> + [LawSuite] +finiteRestrictionLaws restrictionLaw = + [ lawGroup + (finiteRestrictionName restrictionLaw <> " restriction laws") + [ restrictionIdentity restrictionLaw, + restrictionComposition restrictionLaw, + restrictionSourceIdentity restrictionLaw, + restrictionTargetIdentity restrictionLaw + ] + ] + +restrictionIdentity :: + (Show cell, Show val, Eq val) => + FiniteRestrictionLaw cell val -> + LawSuite +restrictionIdentity restrictionLaw = + hUnitLaw "restriction identity" $ + traverse_ + (\(cell, sections) -> + traverse_ + (\section -> + assertEqual + ("identity at " <> show cell) + section + (finiteRestrictionMap restrictionLaw cell cell section) + ) + sections + ) + (Vector.zip (finiteRestrictionCells restrictionLaw) (finiteRestrictionSections restrictionLaw)) + +restrictionComposition :: + (Show cell, Show val, Eq val) => + FiniteRestrictionLaw cell val -> + LawSuite +restrictionComposition restrictionLaw = + relatedRestrictionTripleLaw restrictionLaw "restriction composition" $ + \sourceCell middleCell targetCell section -> + assertEqual + ("composition along " <> show (sourceCell, middleCell, targetCell)) + (finiteRestrictionMap restrictionLaw sourceCell targetCell section) + ( finiteRestrictionMap restrictionLaw middleCell targetCell + (finiteRestrictionMap restrictionLaw sourceCell middleCell section) + ) + +restrictionSourceIdentity :: + (Show cell, Show val, Eq val) => + FiniteRestrictionLaw cell val -> + LawSuite +restrictionSourceIdentity restrictionLaw = + relatedRestrictionPairLaw restrictionLaw "restriction source identity" $ + \sourceCell targetCell section -> + assertEqual + ("source identity along " <> show (sourceCell, targetCell)) + (finiteRestrictionMap restrictionLaw sourceCell targetCell section) + ( finiteRestrictionMap restrictionLaw sourceCell targetCell + (finiteRestrictionMap restrictionLaw sourceCell sourceCell section) + ) + +restrictionTargetIdentity :: + (Show cell, Show val, Eq val) => + FiniteRestrictionLaw cell val -> + LawSuite +restrictionTargetIdentity restrictionLaw = + relatedRestrictionPairLaw restrictionLaw "restriction target identity" $ + \sourceCell targetCell section -> + assertEqual + ("target identity along " <> show (sourceCell, targetCell)) + (finiteRestrictionMap restrictionLaw sourceCell targetCell section) + ( finiteRestrictionMap restrictionLaw targetCell targetCell + (finiteRestrictionMap restrictionLaw sourceCell targetCell section) + ) + +relatedRestrictionPairLaw :: + FiniteRestrictionLaw cell val -> + String -> + (cell -> cell -> val -> Assertion) -> + LawSuite +relatedRestrictionPairLaw restrictionLaw label check = + hUnitLaw label $ + traverse_ + (\(sourceCell, sourceUpperSet, sourceSections) -> + traverseIntSet_ sourceUpperSet $ \targetIndex -> + withRestrictionCell restrictionLaw targetIndex $ \targetCell -> + traverse_ (check sourceCell targetCell) sourceSections + ) + (restrictionRows restrictionLaw) + +relatedRestrictionTripleLaw :: + FiniteRestrictionLaw cell val -> + String -> + (cell -> cell -> cell -> val -> Assertion) -> + LawSuite +relatedRestrictionTripleLaw restrictionLaw label check = + hUnitLaw label $ + traverse_ + (\(sourceCell, sourceUpperSet, sourceSections) -> + traverseIntSet_ sourceUpperSet $ \middleIndex -> + withRestrictionCell restrictionLaw middleIndex $ \middleCell -> + withRestrictionUpperSet restrictionLaw middleIndex $ \middleUpperSet -> + traverseIntSet_ middleUpperSet $ \targetIndex -> + withRestrictionCell restrictionLaw targetIndex $ \targetCell -> + traverse_ (check sourceCell middleCell targetCell) sourceSections + ) + (restrictionRows restrictionLaw) + +restrictionRows :: + FiniteRestrictionLaw cell val -> + Vector (cell, IntSet, [val]) +restrictionRows restrictionLaw = + Vector.zip3 + (finiteRestrictionCells restrictionLaw) + (finiteRestrictionUpperSets restrictionLaw) + (finiteRestrictionSections restrictionLaw) + +traverseIntSet_ :: IntSet -> (Int -> Assertion) -> Assertion +traverseIntSet_ indices action = + IntSet.foldr (\denseIndex rest -> action denseIndex *> rest) (pure ()) indices + +withRestrictionCell :: + FiniteRestrictionLaw cell val -> + Int -> + (cell -> Assertion) -> + Assertion +withRestrictionCell restrictionLaw denseIndex useCell = + case finiteRestrictionCells restrictionLaw Vector.!? denseIndex of + Nothing -> + assertFailure + ( "finite restriction cell obstruction: " + <> show (RestrictionCellIndexOutOfBounds denseIndex) + ) + Just cell -> useCell cell + +withRestrictionUpperSet :: + FiniteRestrictionLaw cell val -> + Int -> + (IntSet -> Assertion) -> + Assertion +withRestrictionUpperSet restrictionLaw denseIndex useUpperSet = + case finiteRestrictionUpperSets restrictionLaw Vector.!? denseIndex of + Nothing -> + assertFailure + ( "finite restriction relation obstruction: " + <> show (RestrictionUpperSetIndexOutOfBounds denseIndex) + ) + Just upperSet -> useUpperSet upperSet diff --git a/src-test-laws/Moonlight/Pale/Test/Laws/Suite.hs b/src-test-laws/Moonlight/Pale/Test/Laws/Suite.hs new file mode 100644 --- /dev/null +++ b/src-test-laws/Moonlight/Pale/Test/Laws/Suite.hs @@ -0,0 +1,78 @@ +{-| A test-tree algebra for QuickCheck, Hedgehog, HUnit, and nested laws. -} +module Moonlight.Pale.Test.Laws.Suite + ( LawSuite, + quickCheckLaw, + namedQuickCheckLaw, + hedgehogLaw, + namedHedgehogLaw, + hUnitLaw, + testTreeLaw, + lawGroup, + renderLawSuite, + ) +where + +import Data.Kind (Type) +import qualified Hedgehog as HH +import Moonlight.Core (IsLawName (..)) +import Prelude (Bool, Show, String, map, (.), (>>=)) +import Test.Tasty (TestTree, testGroup) +import qualified Test.Tasty.Hedgehog as TH +import Test.Tasty.HUnit (Assertion, testCase) +import qualified Test.Tasty.QuickCheck as QC + +type LawSuite :: Type +data LawSuite + = QuickCheckLaw !String !QC.Property + | HedgehogLaw !String !HH.Property + | HUnitLaw !String !Assertion + | EmbeddedTest !TestTree + | LawGroup !String ![LawSuite] + +quickCheckLaw :: QC.Testable property => String -> property -> LawSuite +quickCheckLaw lawLabel lawProperty = + QuickCheckLaw lawLabel (QC.property lawProperty) + +namedQuickCheckLaw :: + (IsLawName lawName, QC.Testable property) => + lawName -> + property -> + LawSuite +namedQuickCheckLaw lawName = + quickCheckLaw (lawNameText lawName) + +hedgehogLaw :: Show value => String -> HH.Gen value -> (value -> Bool) -> LawSuite +hedgehogLaw lawLabel generator predicate = + HedgehogLaw lawLabel (HH.property (HH.forAll generator >>= HH.assert . predicate)) + +namedHedgehogLaw :: + (IsLawName lawName, Show value) => + lawName -> + HH.Gen value -> + (value -> Bool) -> + LawSuite +namedHedgehogLaw lawName = + hedgehogLaw (lawNameText lawName) + +hUnitLaw :: String -> Assertion -> LawSuite +hUnitLaw = HUnitLaw + +testTreeLaw :: TestTree -> LawSuite +testTreeLaw = EmbeddedTest + +lawGroup :: String -> [LawSuite] -> LawSuite +lawGroup = LawGroup + +renderLawSuite :: LawSuite -> TestTree +renderLawSuite lawSuite = + case lawSuite of + QuickCheckLaw lawLabel lawProperty -> + QC.testProperty lawLabel lawProperty + HedgehogLaw lawLabel lawProperty -> + TH.testProperty lawLabel lawProperty + HUnitLaw lawLabel assertion -> + testCase lawLabel assertion + EmbeddedTest testTree -> + testTree + LawGroup groupLabel nestedLaws -> + testGroup groupLabel (map renderLawSuite nestedLaws) diff --git a/src-test-surface/Moonlight/Pale/Test/ImportDiscipline.hs b/src-test-surface/Moonlight/Pale/Test/ImportDiscipline.hs new file mode 100644 --- /dev/null +++ b/src-test-surface/Moonlight/Pale/Test/ImportDiscipline.hs @@ -0,0 +1,119 @@ +{-| Assertions that discovered sheaf imports match an allowed local-module manifest. -} +module Moonlight.Pale.Test.ImportDiscipline + ( SheafManifest (..), + assertSheafDiscipline, + ) +where + +import Data.Kind (Type) +import Data.Function ((&)) +import Data.List (intercalate, isPrefixOf) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set (Set) +import Data.Set qualified as Set +import Moonlight.Pale.Test.ImportDiscipline.Registry + ( assertRegisteredSetMatches, + discoverModuleSurfaces, + moduleSurfaceIdentity, + moduleSurfaceImportedNames, + renderSourceDiscoveryFailure, + ) +import Moonlight.Pale.Test.Resources + ( renderResourcePathError, + resolvePackageDirectory, + ) +import Test.Tasty.HUnit (Assertion, assertFailure) + +type SheafManifest :: Type +data SheafManifest = SheafManifest + { sheafModulePrefix :: String, + sheafAllowedImports :: Map String (Set String) + } + +assertSheafDiscipline :: FilePath -> FilePath -> SheafManifest -> Assertion +assertSheafDiscipline packageMarker relativeDirectory sheafManifest = + let modulePrefix = sheafModulePrefix sheafManifest + allowedImports = sheafAllowedImports sheafManifest + in + resolvePackageDirectory packageMarker relativeDirectory + >>= either + (assertFailure . renderResourcePathError) + (\packageDirectory -> do + discoverPrefixedModuleImports packageDirectory modulePrefix + >>= either + (assertFailure . intercalate "\n") + ( \discoveredImports -> do + assertRegisteredSetMatches + "discovered sheaf modules must match the declared layer registry" + (Map.keysSet allowedImports) + (Map.keysSet discoveredImports) + let violations = + Map.toAscList discoveredImports + >>= \(moduleName, importedModules) -> + let allowedModules = Map.findWithDefault Set.empty moduleName allowedImports + forbiddenModules = + importedModules + & flip Set.difference allowedModules + & Set.toAscList + in + if null forbiddenModules + then [] + else + [ moduleName + <> " imports forbidden local modules " + <> show forbiddenModules + <> "; imported local modules = " + <> show (Set.toAscList importedModules) + <> "; allowed local modules = " + <> show (Set.toAscList allowedModules) + ] + if null violations + then pure () + else assertFailure (intercalate "\n" violations) + ) + ) + +discoverPrefixedModuleImports :: FilePath -> String -> IO (Either [String] (Map String (Set String))) +discoverPrefixedModuleImports packageDirectory modulePrefix = + discoverModuleSurfaces packageDirectory + >>= pure + . either + (Left . fmap renderSourceDiscoveryFailure . NonEmpty.toList) + (foldl' collectModule (Right Map.empty)) + where + collectModule accumulatedModules moduleSurface = + accumulatedModules + >>= \modulesByName -> + case moduleSurfaceIdentity moduleSurface of + Nothing -> + Right modulesByName + Just moduleName + | not (moduleNameWithinPrefix modulePrefix moduleName) -> + Right modulesByName + | Map.member moduleName modulesByName -> + Left ["duplicate module identity discovered: " <> moduleName] + | otherwise -> + Right + ( Map.insert + moduleName + (localModuleImports modulePrefix (moduleSurfaceImportedNames moduleSurface)) + modulesByName + ) + +localModuleImports :: String -> Set String -> Set String +localModuleImports modulePrefix = + Set.filter (moduleNameWithinPrefix modulePrefix) + +moduleNameWithinPrefix :: String -> String -> Bool +moduleNameWithinPrefix modulePrefix moduleName = + moduleNameComponents modulePrefix `isPrefixOf` moduleNameComponents moduleName + +moduleNameComponents :: String -> [String] +moduleNameComponents moduleName = + case break (== '.') moduleName of + (component, []) -> + [component] + (component, _ : remainingName) -> + component : moduleNameComponents remainingName diff --git a/src-test-surface/Moonlight/Pale/Test/ImportDiscipline/Registry.hs b/src-test-surface/Moonlight/Pale/Test/ImportDiscipline/Registry.hs new file mode 100644 --- /dev/null +++ b/src-test-surface/Moonlight/Pale/Test/ImportDiscipline/Registry.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE LambdaCase #-} + +{-| Cabal metadata and parsed-source discovery for import-discipline tests. -} +module Moonlight.Pale.Test.ImportDiscipline.Registry + ( CabalComponentMetadata, + CabalComponentSelector (..), + CabalMetadataObstruction, + CabalPackageMetadata, + SourceDiscoveryFailure (..), + ModuleSurface, + assertRegisteredSetMatches, + cabalComponentExposedModules, + cabalComponentOtherModules, + cabalComponentSourceDirectories, + cabalLibraryComponents, + discoverParsedHaskellFiles, + discoverParsedHaskellFilesWithExcludes, + discoverModuleSurfaces, + moduleSurfaceExportedNames, + moduleSurfaceIdentity, + moduleSurfaceImportedNames, + parseCabalPackageMetadata, + parseModuleSurfaceFile, + renderCabalComponentSelector, + renderCabalMetadataObstruction, + renderSourceDiscoveryFailure, + selectCabalComponentMetadata, + ) +where + +import Data.Bifunctor (first) +import Control.Exception + ( SomeAsyncException, + SomeException, + displayException, + fromException, + throwIO, + try, + ) +import Data.Either (partitionEithers) +import Data.Function ((&)) +import Data.List (intercalate, sort) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Data.Text.Encoding qualified as TextEncoding +import Distribution.ModuleName qualified as CabalModuleName +import Distribution.Fields.ParseResult (runParseResult) +import Distribution.PackageDescription + ( BuildInfo (hsSourceDirs, otherModules), + GenericPackageDescription (condLibrary, condSubLibraries, condTestSuites), + Library (exposedModules, libBuildInfo), + TestSuite (testBuildInfo), + ) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) +import Distribution.Parsec.Error (PError, showPError) +import Distribution.Types.UnqualComponentName (unUnqualComponentName) +import Distribution.Utils.Path (getSymbolicPath) +import Moonlight.Pale.Ghc.ModuleSurface + ( ModuleSurface (..), + explicitExportNames, + moduleSurfaceFromGhcPs, + parseHsModule, + renderGhcParseFailure, + unParsedModuleName, + unParsedName, + ) +import System.Directory (canonicalizePath, doesDirectoryExist, listDirectory, pathIsSymbolicLink) +import System.FilePath (takeExtension, ()) +import Test.Tasty.HUnit (Assertion, assertFailure) + +data CabalComponentSelector + = CabalMainLibrary + | CabalNamedLibrary !String + | CabalTestSuite !String + deriving stock (Eq, Ord, Show) + +data CabalComponentMetadata = CabalComponentMetadata + { cabalComponentSourceDirectories :: !(Set FilePath), + cabalComponentExposedModules :: !(Set String), + cabalComponentOtherModules :: !(Set String) + } + deriving stock (Eq, Show) + +instance Semigroup CabalComponentMetadata where + leftMetadata <> rightMetadata = + CabalComponentMetadata + { cabalComponentSourceDirectories = + cabalComponentSourceDirectories leftMetadata + <> cabalComponentSourceDirectories rightMetadata, + cabalComponentExposedModules = + cabalComponentExposedModules leftMetadata + <> cabalComponentExposedModules rightMetadata, + cabalComponentOtherModules = + cabalComponentOtherModules leftMetadata + <> cabalComponentOtherModules rightMetadata + } + +instance Monoid CabalComponentMetadata where + mempty = + CabalComponentMetadata + { cabalComponentSourceDirectories = Set.empty, + cabalComponentExposedModules = Set.empty, + cabalComponentOtherModules = Set.empty + } + +newtype CabalPackageMetadata = CabalPackageMetadata + { cabalPackageComponents :: [(CabalComponentSelector, CabalComponentMetadata)] + } + +data CabalMetadataObstruction + = CabalParseObstruction !(NonEmpty PError) + | CabalComponentAbsent !CabalComponentSelector + +data SourceDiscoveryFailure + = SourceDirectoryTraversalFailed !FilePath !String + | SourceFileReadFailed !FilePath !String + | SourceFileParseFailed !FilePath !String + deriving stock (Eq, Show) + +renderSourceDiscoveryFailure :: SourceDiscoveryFailure -> String +renderSourceDiscoveryFailure = \case + SourceDirectoryTraversalFailed rootDirectory exceptionText -> + rootDirectory <> ": directory traversal failed: " <> exceptionText + SourceFileReadFailed sourcePath exceptionText -> + sourcePath <> ": read failed: " <> exceptionText + SourceFileParseFailed sourcePath parseError -> + sourcePath <> ": " <> parseError + +assertRegisteredSetMatches :: String -> Set String -> Set String -> Assertion +assertRegisteredSetMatches label expectedEntries registeredEntries = + let missingEntries = Set.toAscList (Set.difference expectedEntries registeredEntries) + unexpectedEntries = Set.toAscList (Set.difference registeredEntries expectedEntries) + in + if null missingEntries && null unexpectedEntries + then pure () + else + assertFailure + ( intercalate + "\n" + [ label, + "missing: " <> show missingEntries, + "unexpected: " <> show unexpectedEntries, + "expected: " <> show (Set.toAscList expectedEntries), + "registered: " <> show (Set.toAscList registeredEntries) + ] + ) + +parseCabalPackageMetadata :: String -> Either CabalMetadataObstruction CabalPackageMetadata +parseCabalPackageMetadata cabalContents = + case snd (runParseResult (parseGenericPackageDescription (TextEncoding.encodeUtf8 (Text.pack cabalContents)))) of + Left (_, parseErrors) -> + Left (CabalParseObstruction parseErrors) + Right genericDescription -> + Right (packageMetadataFromDescription genericDescription) + +selectCabalComponentMetadata :: + CabalComponentSelector -> + CabalPackageMetadata -> + Either CabalMetadataObstruction CabalComponentMetadata +selectCabalComponentMetadata componentSelector packageMetadata = + maybe + (Left (CabalComponentAbsent componentSelector)) + Right + (lookup componentSelector (cabalPackageComponents packageMetadata)) + +cabalLibraryComponents :: + CabalPackageMetadata -> + [(CabalComponentSelector, CabalComponentMetadata)] +cabalLibraryComponents = + filter (isLibrarySelector . fst) . cabalPackageComponents + +renderCabalComponentSelector :: CabalComponentSelector -> String +renderCabalComponentSelector CabalMainLibrary = + "library" +renderCabalComponentSelector (CabalNamedLibrary componentName) = + "library " <> componentName +renderCabalComponentSelector (CabalTestSuite componentName) = + "test-suite " <> componentName + +renderCabalMetadataObstruction :: FilePath -> CabalMetadataObstruction -> String +renderCabalMetadataObstruction cabalPath cabalObstruction = + case cabalObstruction of + CabalParseObstruction parseErrors -> + intercalate "\n" (NonEmpty.toList (fmap (showPError cabalPath) parseErrors)) + CabalComponentAbsent componentSelector -> + cabalPath <> ": missing Cabal component " <> renderCabalComponentSelector componentSelector + +packageMetadataFromDescription :: GenericPackageDescription -> CabalPackageMetadata +packageMetadataFromDescription genericDescription = + CabalPackageMetadata + { cabalPackageComponents = + maybe + [] + (\conditionalLibrary -> [(CabalMainLibrary, foldMap libraryMetadata conditionalLibrary)]) + (condLibrary genericDescription) + <> fmap + ( \(componentName, conditionalLibrary) -> + ( CabalNamedLibrary (unUnqualComponentName componentName), + foldMap libraryMetadata conditionalLibrary + ) + ) + (condSubLibraries genericDescription) + <> fmap + ( \(componentName, conditionalTestSuite) -> + ( CabalTestSuite (unUnqualComponentName componentName), + foldMap testSuiteMetadata conditionalTestSuite + ) + ) + (condTestSuites genericDescription) + } + +libraryMetadata :: Library -> CabalComponentMetadata +libraryMetadata library = + buildInfoMetadata (libBuildInfo library) + <> mempty + { cabalComponentExposedModules = + Set.fromList (fmap renderCabalModuleName (exposedModules library)) + } + +testSuiteMetadata :: TestSuite -> CabalComponentMetadata +testSuiteMetadata = + buildInfoMetadata . testBuildInfo + +buildInfoMetadata :: BuildInfo -> CabalComponentMetadata +buildInfoMetadata buildInfo = + CabalComponentMetadata + { cabalComponentSourceDirectories = + Set.fromList (fmap getSymbolicPath (hsSourceDirs buildInfo)), + cabalComponentExposedModules = Set.empty, + cabalComponentOtherModules = + Set.fromList (fmap renderCabalModuleName (otherModules buildInfo)) + } + +renderCabalModuleName :: CabalModuleName.ModuleName -> String +renderCabalModuleName = + intercalate "." . CabalModuleName.components + +isLibrarySelector :: CabalComponentSelector -> Bool +isLibrarySelector componentSelector = + case componentSelector of + CabalMainLibrary -> True + CabalNamedLibrary _ -> True + CabalTestSuite _ -> False + +discoverModuleSurfaces :: + FilePath -> + IO (Either (NonEmpty SourceDiscoveryFailure) [ModuleSurface]) +discoverModuleSurfaces rootDirectory = do + parsedFiles <- + discoverParsedHaskellFiles + (\path -> first renderGhcParseFailure . parseHsModule path) + rootDirectory + pure + ( parsedFiles >>= \files -> + collectDiscoveryResults (fmap parseSurface files) + ) + where + parseSurface (sourcePath, moduleAst) = + first + (SourceFileParseFailed sourcePath . show) + (moduleSurfaceFromGhcPs moduleAst) + +parseModuleSurfaceFile :: + FilePath -> + IO (Either SourceDiscoveryFailure ModuleSurface) +parseModuleSurfaceFile sourcePath = do + sourceResult <- + trySynchronous + (SourceFileReadFailed sourcePath . displayException) + (Text.unpack <$> TextIO.readFile sourcePath) + pure + ( sourceResult + >>= first (SourceFileParseFailed sourcePath . renderGhcParseFailure) + . parseHsModule sourcePath + >>= first (SourceFileParseFailed sourcePath . show) . moduleSurfaceFromGhcPs + ) + +discoverParsedHaskellFiles :: + (FilePath -> String -> Either String value) -> + FilePath -> + IO (Either (NonEmpty SourceDiscoveryFailure) [(FilePath, value)]) +discoverParsedHaskellFiles parser rootDirectory = + discoverParsedHaskellFilesWithExcludes [] parser rootDirectory + +discoverParsedHaskellFilesWithExcludes :: + [FilePath] -> + (FilePath -> String -> Either String value) -> + FilePath -> + IO (Either (NonEmpty SourceDiscoveryFailure) [(FilePath, value)]) +discoverParsedHaskellFilesWithExcludes excludedDirectoryNames parser rootDirectory = do + sourcePathsResult <- + trySynchronous + (SourceDirectoryTraversalFailed rootDirectory . displayException) + (haskellModuleFilesWithExcludes excludedDirectoryNames rootDirectory) + case sourcePathsResult of + Left traversalFailure -> + pure (Left (traversalFailure NonEmpty.:| [])) + Right sourcePaths -> + collectDiscoveryResults + <$> traverse (readAndParseSourceFile parser) sourcePaths + +readAndParseSourceFile :: + (FilePath -> String -> Either String value) -> + FilePath -> + IO (Either SourceDiscoveryFailure (FilePath, value)) +readAndParseSourceFile parser sourcePath = do + sourceResult <- + trySynchronous + (SourceFileReadFailed sourcePath . displayException) + (Text.unpack <$> TextIO.readFile sourcePath) + pure + ( sourceResult + >>= first (SourceFileParseFailed sourcePath) . parser sourcePath + >>= \parsedValue -> Right (sourcePath, parsedValue) + ) + +moduleSurfaceIdentity :: ModuleSurface -> Maybe String +moduleSurfaceIdentity moduleSurface = + fmap unParsedModuleName (surfaceModuleName moduleSurface) + +moduleSurfaceImportedNames :: ModuleSurface -> Set String +moduleSurfaceImportedNames moduleSurface = + surfaceImportedModules moduleSurface + & Set.map unParsedModuleName + +moduleSurfaceExportedNames :: ModuleSurface -> Maybe (Set String) +moduleSurfaceExportedNames moduleSurface = + explicitExportNames (surfaceExports moduleSurface) + & fmap (Set.map unParsedName) + +haskellModuleFilesWithExcludes :: [FilePath] -> FilePath -> IO [FilePath] +haskellModuleFilesWithExcludes excludedDirectoryNames rootDirectory = + canonicalizePath rootDirectory + >>= walkHaskellModuleFiles Set.empty + where + walkHaskellModuleFiles visitedDirectories currentDirectory + | Set.member currentDirectory visitedDirectories = + pure [] + | otherwise = + sort + <$> listDirectory currentDirectory + >>= traverse + (discoverEntry (Set.insert currentDirectory visitedDirectories) currentDirectory) + >>= pure . concat + + discoverEntry visitedDirectories currentDirectory entryName = + let entryPath = currentDirectory entryName + in pathIsSymbolicLink entryPath + >>= \isSymbolicLink -> + if isSymbolicLink + then pure [] + else + doesDirectoryExist entryPath + >>= \isDirectory -> + if isDirectory + then + if isExcludedDirectory excludedDirectoryNames entryName + then pure [] + else + canonicalizePath entryPath + >>= walkHaskellModuleFiles visitedDirectories + else + pure + ( if takeExtension entryPath `elem` [".hs", ".lhs"] + then [entryPath] + else [] + ) + +collectDiscoveryResults :: + [Either SourceDiscoveryFailure value] -> + Either (NonEmpty SourceDiscoveryFailure) [value] +collectDiscoveryResults parseResults = + case partitionEithers parseResults of + ([], parsedValues) -> + Right parsedValues + (firstFailure : remainingFailures, _) -> + Left (firstFailure NonEmpty.:| remainingFailures) + +isExcludedDirectory :: [FilePath] -> FilePath -> Bool +isExcludedDirectory excludedDirectoryNames entryName = + entryName `elem` excludedDirectoryNames + +trySynchronous :: + (SomeException -> failure) -> + IO value -> + IO (Either failure value) +trySynchronous toFailure action = do + result <- try action + case result of + Left exceptionValue + | Just asyncException <- + (fromException exceptionValue :: Maybe SomeAsyncException) -> + throwIO asyncException + | otherwise -> + pure (Left (toFailure exceptionValue)) + Right value -> + pure (Right value) diff --git a/src-test/Moonlight/Pale/Test/Assertions.hs b/src-test/Moonlight/Pale/Test/Assertions.hs new file mode 100644 --- /dev/null +++ b/src-test/Moonlight/Pale/Test/Assertions.hs @@ -0,0 +1,100 @@ +{-| Typed-result, numeric-tolerance, and collection assertions. -} +module Moonlight.Pale.Test.Assertions + ( expectRight, + expectRightWithLabel, + expectSome, + assertApproxEqual, + assertNonEmpty, + assertSubsetOf, + withResult, + ) +where + +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Stack (HasCallStack) +import Moonlight.Pale.Test.Core + ( Tolerance, + ToleranceObstruction, + absoluteTolerance, + relativeTolerance, + ) +import Test.Tasty.HUnit (Assertion, assertBool, assertFailure) + +expectedRightMessage :: Show e => e -> String +expectedRightMessage err = "expected Right, got Left: " <> show err + +expectRight :: (HasCallStack, Show e) => Either e a -> IO a +expectRight = either (assertFailure . expectedRightMessage) pure + +expectRightWithLabel :: (HasCallStack, Show e) => String -> Either e a -> IO a +expectRightWithLabel label = + either (\err -> assertFailure (label <> ": " <> expectedRightMessage err)) pure + +expectSome :: HasCallStack => String -> Maybe a -> IO a +expectSome label result = + case result of + Nothing -> assertFailure ("expected Just for " <> label <> ", got Nothing") + Just val -> pure val + +assertApproxEqual :: + HasCallStack => + String -> + Either ToleranceObstruction Tolerance -> + Double -> + Double -> + Assertion +assertApproxEqual label toleranceResult expected actual = + case toleranceResult of + Left toleranceObstruction -> + assertFailure + (label <> ": invalid tolerance: " <> show toleranceObstruction) + Right tolerance + | isNaN expected || isNaN actual -> + assertFailure + (label <> ": NaN is never approximately equal; expected " <> show expected <> ", got " <> show actual) + | isInfinite expected || isInfinite actual -> + assertBool + (label <> ": infinities must be exactly equal; expected " <> show expected <> ", got " <> show actual) + (expected == actual) + | otherwise -> + let absoluteError = abs (actual - expected) + relativeScale = max (abs expected) (abs actual) + relativeLimit = relativeTolerance tolerance * relativeScale + acceptedLimit = max (absoluteTolerance tolerance) relativeLimit + relativeError = + if relativeScale == 0 + then 0 + else absoluteError / relativeScale + in assertBool + ( label + <> ": expected " + <> show expected + <> ", got " + <> show actual + <> "; absolute error " + <> show absoluteError + <> " (limit " + <> show (absoluteTolerance tolerance) + <> "), relative error " + <> show relativeError + <> " (limit " + <> show (relativeTolerance tolerance) + <> ")" + ) + (absoluteError <= acceptedLimit) + +assertNonEmpty :: HasCallStack => [a] -> Assertion +assertNonEmpty xs = + assertBool "expected non-empty list" (not (null xs)) + +assertSubsetOf :: (HasCallStack, Ord a, Show a) => Set a -> Set a -> Assertion +assertSubsetOf subset superset = + let missing = Set.difference subset superset + in assertBool + ("expected subset, missing: " <> show (Set.toList missing)) + (Set.null missing) + +withResult :: (HasCallStack, Show e) => Either e a -> (a -> Assertion) -> Assertion +withResult result check = + either (assertFailure . expectedRightMessage) check result diff --git a/src-test/Moonlight/Pale/Test/Core.hs b/src-test/Moonlight/Pale/Test/Core.hs new file mode 100644 --- /dev/null +++ b/src-test/Moonlight/Pale/Test/Core.hs @@ -0,0 +1,90 @@ +{-| Shared test budgets and validated numeric tolerances. -} +module Moonlight.Pale.Test.Core + ( TestBudget (..), + canonicalTestBudget, + scopedTestBudget, + stressTestBudget, + tightNodeBudget, + tightIterationBudget, + mediumPressureBudget, + generousBudget, + Tolerance, + ToleranceObstruction (..), + mkTolerance, + absoluteTolerance, + relativeTolerance, + physicsTolerance, + exactTolerance, + solverTolerance, + ) +where + +import Data.Kind (Type) + +type TestBudget :: Type +data TestBudget = TestBudget + { testBudgetMaxIterations :: !Int, + testBudgetMaxNodes :: !Int + } + deriving stock (Eq, Show, Read) + +canonicalTestBudget :: TestBudget +canonicalTestBudget = TestBudget {testBudgetMaxIterations = 4, testBudgetMaxNodes = 20} + +scopedTestBudget :: TestBudget +scopedTestBudget = TestBudget {testBudgetMaxIterations = 3, testBudgetMaxNodes = 20} + +stressTestBudget :: TestBudget +stressTestBudget = TestBudget {testBudgetMaxIterations = 30, testBudgetMaxNodes = 1000} + +tightNodeBudget :: TestBudget +tightNodeBudget = TestBudget {testBudgetMaxIterations = 30, testBudgetMaxNodes = 15} + +tightIterationBudget :: TestBudget +tightIterationBudget = TestBudget {testBudgetMaxIterations = 2, testBudgetMaxNodes = 5000} + +mediumPressureBudget :: TestBudget +mediumPressureBudget = TestBudget {testBudgetMaxIterations = 15, testBudgetMaxNodes = 300} + +generousBudget :: TestBudget +generousBudget = TestBudget {testBudgetMaxIterations = 30, testBudgetMaxNodes = 1500} + +type Tolerance :: Type +data Tolerance = Tolerance + { absoluteTolerance :: !Double, + relativeTolerance :: !Double + } + deriving stock (Eq, Show) + +type ToleranceObstruction :: Type +data ToleranceObstruction + = ToleranceNotFinite !Double !Double + | ToleranceNegative !Double !Double + deriving stock (Eq, Show) + +mkTolerance :: Double -> Double -> Either ToleranceObstruction Tolerance +mkTolerance absoluteLimit relativeLimit + | anyNonFinite = + Left (ToleranceNotFinite absoluteLimit relativeLimit) + | absoluteLimit < 0 || relativeLimit < 0 = + Left (ToleranceNegative absoluteLimit relativeLimit) + | otherwise = + Right (Tolerance absoluteLimit relativeLimit) + where + anyNonFinite = + isNaN absoluteLimit + || isInfinite absoluteLimit + || isNaN relativeLimit + || isInfinite relativeLimit + +physicsTolerance :: Tolerance +physicsTolerance = + Tolerance 1.0e-9 1.0e-9 + +exactTolerance :: Tolerance +exactTolerance = + Tolerance 1.0e-12 1.0e-12 + +solverTolerance :: Tolerance +solverTolerance = + Tolerance 1.0e-5 1.0e-5 diff --git a/src-test/Moonlight/Pale/Test/Recursion.hs b/src-test/Moonlight/Pale/Test/Recursion.hs new file mode 100644 --- /dev/null +++ b/src-test/Moonlight/Pale/Test/Recursion.hs @@ -0,0 +1,14 @@ +{-| Recursion identity and interpreter-coherence predicates. -} +module Moonlight.Pale.Test.Recursion + ( cataAfterAnaIdentity, + interpreterCoherence, + ) +where + +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) diff --git a/src-test/Moonlight/Pale/Test/Resources.hs b/src-test/Moonlight/Pale/Test/Resources.hs new file mode 100644 --- /dev/null +++ b/src-test/Moonlight/Pale/Test/Resources.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE DerivingStrategies #-} + +{-| Validated discovery of compiler, package, and resource paths. -} +module Moonlight.Pale.Test.Resources + ( ResourcePathError (..), + renderResourcePathError, + resolveCompilerRoot, + findActiveCabalBuildDirectory, + resolvePackageRoot, + resolveCompilerFile, + resolveCompilerDirectory, + resolvePackageFile, + resolvePackageDirectory, + ) +where + +import Control.Exception + ( SomeAsyncException, + SomeException, + displayException, + fromException, + throwIO, + try, + ) +import Control.Monad (join) +import Data.Kind (Type) +import Data.List (unfoldr) +import Data.Maybe (catMaybes) +import Data.Set qualified as Set +import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, getCurrentDirectory) +import System.Environment (getExecutablePath, lookupEnv) +import System.FilePath (isAbsolute, makeRelative, normalise, splitDirectories, takeDirectory, ()) + +type ResourcePathError :: Type +data ResourcePathError + = CompilerRootNotFound FilePath + | MissingResourceFile FilePath + | MissingResourceDirectory FilePath + | ResourcePathNotRelativeToRoot FilePath + | ResourcePathEscapesRoot FilePath FilePath + | ResourceFilesystemFailure FilePath String + deriving stock (Eq, Show) + +renderResourcePathError :: ResourcePathError -> String +renderResourcePathError resourcePathError = + case resourcePathError of + CompilerRootNotFound packageMarker -> + "unable to locate compiler root with cabal.project and marker: " <> packageMarker + MissingResourceFile filePath -> + "missing resource file: " <> filePath + MissingResourceDirectory directoryPath -> + "missing resource directory: " <> directoryPath + ResourcePathNotRelativeToRoot resourcePath -> + "resource path is not relative to its root: " <> resourcePath + ResourcePathEscapesRoot rootPath escapedPath -> + "resource path escapes root " <> rootPath <> ": " <> escapedPath + ResourceFilesystemFailure contextPath exceptionText -> + "filesystem failure while resolving " <> contextPath <> ": " <> exceptionText + +resolveCompilerRoot :: FilePath -> IO (Either ResourcePathError FilePath) +resolveCompilerRoot packageMarker = + fmap join $ + trySynchronous packageMarker $ do + currentDirectory <- getCurrentDirectory + executableDirectory <- takeDirectory <$> getExecutablePath + maybeCompilerRoot <- + findAnyCompilerRoot + packageMarker + [currentDirectory, executableDirectory] + pure + ( case maybeCompilerRoot of + Nothing -> Left (CompilerRootNotFound packageMarker) + Just compilerRoot -> Right compilerRoot + ) + +resolvePackageRoot :: FilePath -> IO (Either ResourcePathError FilePath) +resolvePackageRoot packageMarker = + fmap + (fmap (\compilerRoot -> normalise (compilerRoot takeDirectory packageMarker))) + (resolveCompilerRoot packageMarker) + +resolveCompilerFile :: FilePath -> FilePath -> IO (Either ResourcePathError FilePath) +resolveCompilerFile = + resolveExistingPath resolveCompilerRoot doesFileExist MissingResourceFile + +resolveCompilerDirectory :: FilePath -> FilePath -> IO (Either ResourcePathError FilePath) +resolveCompilerDirectory = + resolveExistingPath resolveCompilerRoot doesDirectoryExist MissingResourceDirectory + +resolvePackageFile :: FilePath -> FilePath -> IO (Either ResourcePathError FilePath) +resolvePackageFile = + resolveExistingPath resolvePackageRoot doesFileExist MissingResourceFile + +resolvePackageDirectory :: FilePath -> FilePath -> IO (Either ResourcePathError FilePath) +resolvePackageDirectory = + resolveExistingPath resolvePackageRoot doesDirectoryExist MissingResourceDirectory + +resolveExistingPath :: + (FilePath -> IO (Either ResourcePathError FilePath)) -> + (FilePath -> IO Bool) -> + (FilePath -> ResourcePathError) -> + FilePath -> + FilePath -> + IO (Either ResourcePathError FilePath) +resolveExistingPath resolveRoot pathExists toMissingError packageMarker relativePath + | not (pathRelativeToRoot relativePath) = + pure (Left (ResourcePathNotRelativeToRoot relativePath)) + | otherwise = + fmap join $ + trySynchronous (packageMarker relativePath) $ do + rootResult <- resolveRoot packageMarker + case rootResult of + Left rootError -> pure (Left rootError) + Right rootPath -> do + canonicalRoot <- canonicalizePath rootPath + let resolvedPath = normalise (canonicalRoot relativePath) + if not (pathWithinRoot canonicalRoot resolvedPath) + then + pure (Left (ResourcePathEscapesRoot canonicalRoot resolvedPath)) + else do + pathPresent <- pathExists resolvedPath + if pathPresent + then do + canonicalResolvedPath <- canonicalizePath resolvedPath + pure + ( if pathWithinRoot canonicalRoot canonicalResolvedPath + then Right canonicalResolvedPath + else Left (ResourcePathEscapesRoot canonicalRoot canonicalResolvedPath) + ) + else + pure (Left (toMissingError resolvedPath)) + +findActiveCabalBuildDirectory :: IO (Either ResourcePathError (Maybe FilePath)) +findActiveCabalBuildDirectory = + trySynchronous "cache/plan.json" $ do + maybeComponentBuildDirectory <- lookupEnv "HASKELL_DIST_DIR" + executableDirectory <- takeDirectory <$> getExecutablePath + findAnyAncestorDirectory + hasCabalBuildPlan + (catMaybes [maybeComponentBuildDirectory, Just executableDirectory]) + +trySynchronous :: + FilePath -> + IO value -> + IO (Either ResourcePathError value) +trySynchronous contextPath action = do + result <- try action + case result of + Left exceptionValue + | Just asyncException <- + (fromException exceptionValue :: Maybe SomeAsyncException) -> + throwIO asyncException + | otherwise -> + pure + ( Left + (ResourceFilesystemFailure contextPath (displayException (exceptionValue :: SomeException))) + ) + Right value -> + pure (Right value) + +findAncestorDirectory :: (FilePath -> IO Bool) -> FilePath -> IO (Maybe FilePath) +findAncestorDirectory hasMarker directoryPath = + canonicalizePath directoryPath + >>= firstJustM matchingDirectory . ancestorDirectories + where + matchingDirectory candidateDirectory = + hasMarker candidateDirectory + >>= \markerPresent -> + pure + ( if markerPresent + then Just candidateDirectory + else Nothing + ) + +findAnyCompilerRoot :: FilePath -> [FilePath] -> IO (Maybe FilePath) +findAnyCompilerRoot packageMarker = + findAnyAncestorDirectory (hasCompilerRootMarkers packageMarker) + +findAnyAncestorDirectory :: (FilePath -> IO Bool) -> [FilePath] -> IO (Maybe FilePath) +findAnyAncestorDirectory hasMarker seedDirectories = + traverse canonicalizePath seedDirectories + >>= firstJustM (findAncestorDirectory hasMarker) . Set.toAscList . Set.fromList + +ancestorDirectories :: FilePath -> [FilePath] +ancestorDirectories initialDirectory = + initialDirectory : unfoldr parentDirectory initialDirectory + where + parentDirectory childDirectory = + let parent = takeDirectory childDirectory + in if parent == childDirectory + then Nothing + else Just (parent, parent) + +firstJustM :: Monad effect => (candidate -> effect (Maybe result)) -> [candidate] -> effect (Maybe result) +firstJustM inspectCandidate = + foldr + ( \candidate laterResult -> + inspectCandidate candidate + >>= maybe laterResult (pure . Just) + ) + (pure Nothing) + +pathWithinRoot :: FilePath -> FilePath -> Bool +pathWithinRoot rootPath childPath = + let relativePath = makeRelative rootPath childPath + in not (isAbsolute relativePath) + && case splitDirectories relativePath of + ".." : _ -> False + _ -> True + +pathRelativeToRoot :: FilePath -> Bool +pathRelativeToRoot resourcePath = + not (isAbsolute resourcePath) + && case splitDirectories (normalise resourcePath) of + ".." : _ -> False + _ -> True + +hasCompilerRootMarkers :: FilePath -> FilePath -> IO Bool +hasCompilerRootMarkers packageMarker directoryPath = do + hasProject <- doesFileExist (directoryPath "cabal.project") + hasPackage <- doesFileExist (directoryPath packageMarker) + pure (hasProject && hasPackage) + +hasCabalBuildPlan :: FilePath -> IO Bool +hasCabalBuildPlan directoryPath = + doesFileExist (directoryPath "cache" "plan.json") diff --git a/test/bench-measure/Main.hs b/test/bench-measure/Main.hs new file mode 100644 --- /dev/null +++ b/test/bench-measure/Main.hs @@ -0,0 +1,384 @@ +module Main (main) where + +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Word (Word64) +import Moonlight.Pale.Bench.Measure + ( RtsMeasurement (..), + RtsCounter (..), + RtsDelta (..), + RtsDeltaObstruction (..), + RtsSnapshot (..), + checkedRtsDelta, + RtsPhaseBoundaryObservation(..), + RtsPhaseResourceObstruction(..), + combineRtsPhaseMeasurements, + finalizeRtsPhaseMeasurement, + finalizeRtsMeasurement, + measuredRtsPhaseResourceBytes, + measureSample, + rtsPhaseElapsedNanoseconds, + unmeasuredRtsPhaseMeasurement, + ) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit ((@?=), assertFailure, testCase) + +main :: IO () +main = + defaultMain + ( testGroup + "RTS measurement" + [ testCase "all monotone counters produce their exact differences" monotoneDeltaLaw, + testCase "equal snapshots produce the zero delta" zeroDeltaLaw, + testGroup "counter regression obstructions" (fmap counterRegressionLaw allRtsCounters), + testGroup + "extreme monotone signed counters" + (fmap extremeSignedCounterLaw allSignedRtsCounters), + testCase + "pure finalization labels process-wide live and maximum observations" + finalizationSnapshotLaw, + testCase "phase composition is exact" phaseCompositionLaw, + testCase "phase resource obstruction precedence is exhaustive" phaseObstructionPrecedenceLaw, + testCase "phase allocation closes post-GC while copy stops at action" phaseBoundaryDeltaLaw, + testCase "RTS-backed measurement integration succeeds" measurementIntegrationSmokeLaw + ] + ) + +monotoneDeltaLaw :: IO () +monotoneDeltaLaw = + checkedRtsDelta monotoneBeforeSnapshot monotoneAfterSnapshot + @?= Right expectedMonotoneDelta + +zeroDeltaLaw :: IO () +zeroDeltaLaw = + checkedRtsDelta monotoneBeforeSnapshot monotoneBeforeSnapshot + @?= Right zeroRtsDelta + +counterRegressionLaw :: RtsCounter -> TestTree +counterRegressionLaw counter = + testCase (show counter) $ do + let (beforeSnapshot, afterSnapshot) = regressionSnapshots counter + checkedRtsDelta beforeSnapshot afterSnapshot + @?= Left (RtsCounterRegression counter 2 1) + +data SignedRtsCounter + = SignedRtsCounterMutatorCpuNanoseconds + | SignedRtsCounterMutatorElapsedNanoseconds + | SignedRtsCounterGcCpuNanoseconds + | SignedRtsCounterGcElapsedNanoseconds + | SignedRtsCounterCpuNanoseconds + | SignedRtsCounterElapsedNanoseconds + deriving stock (Eq, Show) + +extremeSignedCounterLaw :: SignedRtsCounter -> TestTree +extremeSignedCounterLaw counter = + testCase (show counter) $ + case checkedRtsDelta beforeSnapshot afterSnapshot of + Left obstructionValue -> + assertFailure ("extreme monotone counter was rejected: " <> show obstructionValue) + Right deltaValue -> + signedCounterDelta counter deltaValue @?= maxBound + where + (beforeSnapshot, afterSnapshot) = extremeSignedSnapshots counter + +finalizationSnapshotLaw :: IO () +finalizationSnapshotLaw = + case finalizeRtsMeasurement 17 beforeSnapshot afterActionSnapshot afterPostGcSnapshot "value" 29 of + Left obstructionValue -> + assertFailure ("valid finalization was rejected: " <> show obstructionValue) + Right measurement -> do + rtsMeasurementElapsedNanoseconds measurement @?= 17 + rtsDeltaAllocatedBytes (rtsMeasurementDelta measurement) @?= 23 + rtsMeasurementProcessLiveBytesAfterGc measurement @?= 31 + rtsMeasurementProcessMaxLiveBytes measurement @?= 43 + rtsMeasurementValue measurement @?= "value" + rtsMeasurementDigest measurement @?= 29 + where + beforeSnapshot = zeroRtsSnapshot + afterActionSnapshot = + zeroRtsSnapshot + { rtsSnapshotAllocatedBytes = 23 + , rtsSnapshotLiveBytes = 41 + , rtsSnapshotMaxLiveBytes = 37 + } + afterPostGcSnapshot = + afterActionSnapshot + { rtsSnapshotLiveBytes = 31 + , rtsSnapshotMaxLiveBytes = 43 + } + +phaseCompositionLaw :: IO () +phaseCompositionLaw = do + rtsPhaseElapsedNanoseconds combinedMeasurement @?= 12 + measuredRtsPhaseResourceBytes combinedMeasurement @?= Right (18, 9) + where + combinedMeasurement = + combineRtsPhaseMeasurements + (finalizeRtsPhaseMeasurement 5 (phaseSnapshots 13 7)) + (finalizeRtsPhaseMeasurement 7 (phaseSnapshots 5 2)) + +phaseObstructionPrecedenceLaw :: IO () +phaseObstructionPrecedenceLaw = do + measuredRtsPhaseResourceBytes + ( combineRtsPhaseMeasurements + (finalizeRtsPhaseMeasurement 2 (phaseSnapshots 1 1)) + unmeasuredRtsPhaseMeasurement + ) + @?= Left RtsPhaseResourcesUnmeasured + measuredRtsPhaseResourceBytes + (combineRtsPhaseMeasurements unmeasuredRtsPhaseMeasurement unavailableMeasurement) + @?= Left RtsPhaseStatsUnavailable + measuredRtsPhaseResourceBytes + (combineRtsPhaseMeasurements refusedMeasurement unavailableMeasurement) + @?= Left + ( RtsPhaseDeltaRefused + (RtsCounterRegression RtsCounterAllocatedBytes 2 1 :| []) + ) + where + unavailableMeasurement = + finalizeRtsPhaseMeasurement 3 RtsPhaseBoundaryStatsUnavailable + refusedMeasurement = + finalizeRtsPhaseMeasurement + 4 + ( RtsPhaseBoundarySnapshots + (zeroRtsSnapshot {rtsSnapshotAllocatedBytes = 2}) + (zeroRtsSnapshot {rtsSnapshotAllocatedBytes = 1}) + (zeroRtsSnapshot {rtsSnapshotAllocatedBytes = 1}) + ) + +phaseBoundaryDeltaLaw :: IO () +phaseBoundaryDeltaLaw = + measuredRtsPhaseResourceBytes + ( finalizeRtsPhaseMeasurement + 11 + ( RtsPhaseBoundarySnapshots + zeroRtsSnapshot + ( zeroRtsSnapshot + { rtsSnapshotAllocatedBytes = 10 + , rtsSnapshotCopiedBytes = 7 + } + ) + ( zeroRtsSnapshot + { rtsSnapshotAllocatedBytes = 13 + , rtsSnapshotCopiedBytes = 19 + } + ) + ) + ) + @?= Right (13, 7) + +phaseSnapshots :: Word64 -> Word64 -> RtsPhaseBoundaryObservation +phaseSnapshots allocatedBytes copiedBytes = + RtsPhaseBoundarySnapshots + zeroRtsSnapshot + ( zeroRtsSnapshot + { rtsSnapshotAllocatedBytes = allocatedBytes + , rtsSnapshotCopiedBytes = copiedBytes + } + ) + ( zeroRtsSnapshot + { rtsSnapshotAllocatedBytes = allocatedBytes + , rtsSnapshotCopiedBytes = copiedBytes + } + ) + +measurementIntegrationSmokeLaw :: IO () +measurementIntegrationSmokeLaw = do + measurementResult <- + measureSample + 1 + (const (pure 41)) + (\input -> pure (Right (input + 1) :: Either String Int)) + (\value -> value `seq` ()) + id + case measurementResult of + Left failure -> + assertFailure ("RTS-backed measurement failed: " <> show failure) + Right measurement -> do + rtsMeasurementValue measurement @?= 42 + rtsMeasurementDigest measurement @?= 42 + +allRtsCounters :: [RtsCounter] +allRtsCounters = + [ RtsCounterGcs, + RtsCounterMajorGcs, + RtsCounterAllocatedBytes, + RtsCounterCopiedBytes, + RtsCounterMutatorCpuNanoseconds, + RtsCounterMutatorElapsedNanoseconds, + RtsCounterGcCpuNanoseconds, + RtsCounterGcElapsedNanoseconds, + RtsCounterCpuNanoseconds, + RtsCounterElapsedNanoseconds + ] + +allSignedRtsCounters :: [SignedRtsCounter] +allSignedRtsCounters = + [ SignedRtsCounterMutatorCpuNanoseconds + , SignedRtsCounterMutatorElapsedNanoseconds + , SignedRtsCounterGcCpuNanoseconds + , SignedRtsCounterGcElapsedNanoseconds + , SignedRtsCounterCpuNanoseconds + , SignedRtsCounterElapsedNanoseconds + ] + +extremeSignedSnapshots :: SignedRtsCounter -> (RtsSnapshot, RtsSnapshot) +extremeSignedSnapshots counter = + case counter of + SignedRtsCounterMutatorCpuNanoseconds -> + ( zeroRtsSnapshot {rtsSnapshotMutatorCpuNanoseconds = minBound} + , zeroRtsSnapshot {rtsSnapshotMutatorCpuNanoseconds = maxBound} + ) + SignedRtsCounterMutatorElapsedNanoseconds -> + ( zeroRtsSnapshot {rtsSnapshotMutatorElapsedNanoseconds = minBound} + , zeroRtsSnapshot {rtsSnapshotMutatorElapsedNanoseconds = maxBound} + ) + SignedRtsCounterGcCpuNanoseconds -> + ( zeroRtsSnapshot {rtsSnapshotGcCpuNanoseconds = minBound} + , zeroRtsSnapshot {rtsSnapshotGcCpuNanoseconds = maxBound} + ) + SignedRtsCounterGcElapsedNanoseconds -> + ( zeroRtsSnapshot {rtsSnapshotGcElapsedNanoseconds = minBound} + , zeroRtsSnapshot {rtsSnapshotGcElapsedNanoseconds = maxBound} + ) + SignedRtsCounterCpuNanoseconds -> + ( zeroRtsSnapshot {rtsSnapshotCpuNanoseconds = minBound} + , zeroRtsSnapshot {rtsSnapshotCpuNanoseconds = maxBound} + ) + SignedRtsCounterElapsedNanoseconds -> + ( zeroRtsSnapshot {rtsSnapshotElapsedNanoseconds = minBound} + , zeroRtsSnapshot {rtsSnapshotElapsedNanoseconds = maxBound} + ) + +signedCounterDelta :: SignedRtsCounter -> RtsDelta -> Word64 +signedCounterDelta counter deltaValue = + case counter of + SignedRtsCounterMutatorCpuNanoseconds -> rtsDeltaMutatorCpuNanoseconds deltaValue + SignedRtsCounterMutatorElapsedNanoseconds -> rtsDeltaMutatorElapsedNanoseconds deltaValue + SignedRtsCounterGcCpuNanoseconds -> rtsDeltaGcCpuNanoseconds deltaValue + SignedRtsCounterGcElapsedNanoseconds -> rtsDeltaGcElapsedNanoseconds deltaValue + SignedRtsCounterCpuNanoseconds -> rtsDeltaCpuNanoseconds deltaValue + SignedRtsCounterElapsedNanoseconds -> rtsDeltaElapsedNanoseconds deltaValue + +regressionSnapshots :: RtsCounter -> (RtsSnapshot, RtsSnapshot) +regressionSnapshots = \case + RtsCounterGcs -> + ( zeroRtsSnapshot {rtsSnapshotGcs = 2}, + zeroRtsSnapshot {rtsSnapshotGcs = 1} + ) + RtsCounterMajorGcs -> + ( zeroRtsSnapshot {rtsSnapshotMajorGcs = 2}, + zeroRtsSnapshot {rtsSnapshotMajorGcs = 1} + ) + RtsCounterAllocatedBytes -> + ( zeroRtsSnapshot {rtsSnapshotAllocatedBytes = 2}, + zeroRtsSnapshot {rtsSnapshotAllocatedBytes = 1} + ) + RtsCounterCopiedBytes -> + ( zeroRtsSnapshot {rtsSnapshotCopiedBytes = 2}, + zeroRtsSnapshot {rtsSnapshotCopiedBytes = 1} + ) + RtsCounterMutatorCpuNanoseconds -> + ( zeroRtsSnapshot {rtsSnapshotMutatorCpuNanoseconds = 2}, + zeroRtsSnapshot {rtsSnapshotMutatorCpuNanoseconds = 1} + ) + RtsCounterMutatorElapsedNanoseconds -> + ( zeroRtsSnapshot {rtsSnapshotMutatorElapsedNanoseconds = 2}, + zeroRtsSnapshot {rtsSnapshotMutatorElapsedNanoseconds = 1} + ) + RtsCounterGcCpuNanoseconds -> + ( zeroRtsSnapshot {rtsSnapshotGcCpuNanoseconds = 2}, + zeroRtsSnapshot {rtsSnapshotGcCpuNanoseconds = 1} + ) + RtsCounterGcElapsedNanoseconds -> + ( zeroRtsSnapshot {rtsSnapshotGcElapsedNanoseconds = 2}, + zeroRtsSnapshot {rtsSnapshotGcElapsedNanoseconds = 1} + ) + RtsCounterCpuNanoseconds -> + ( zeroRtsSnapshot {rtsSnapshotCpuNanoseconds = 2}, + zeroRtsSnapshot {rtsSnapshotCpuNanoseconds = 1} + ) + RtsCounterElapsedNanoseconds -> + ( zeroRtsSnapshot {rtsSnapshotElapsedNanoseconds = 2}, + zeroRtsSnapshot {rtsSnapshotElapsedNanoseconds = 1} + ) + +zeroRtsSnapshot :: RtsSnapshot +zeroRtsSnapshot = + RtsSnapshot + { rtsSnapshotGcs = 0, + rtsSnapshotMajorGcs = 0, + rtsSnapshotAllocatedBytes = 0, + rtsSnapshotCopiedBytes = 0, + rtsSnapshotMutatorCpuNanoseconds = 0, + rtsSnapshotMutatorElapsedNanoseconds = 0, + rtsSnapshotGcCpuNanoseconds = 0, + rtsSnapshotGcElapsedNanoseconds = 0, + rtsSnapshotCpuNanoseconds = 0, + rtsSnapshotElapsedNanoseconds = 0, + rtsSnapshotLiveBytes = 0, + rtsSnapshotMaxLiveBytes = 0 + } + +monotoneBeforeSnapshot :: RtsSnapshot +monotoneBeforeSnapshot = + RtsSnapshot + { rtsSnapshotGcs = 2, + rtsSnapshotMajorGcs = 4, + rtsSnapshotAllocatedBytes = 10, + rtsSnapshotCopiedBytes = 40, + rtsSnapshotMutatorCpuNanoseconds = 50, + rtsSnapshotMutatorElapsedNanoseconds = 60, + rtsSnapshotGcCpuNanoseconds = 70, + rtsSnapshotGcElapsedNanoseconds = 80, + rtsSnapshotCpuNanoseconds = 90, + rtsSnapshotElapsedNanoseconds = 100, + rtsSnapshotLiveBytes = 11, + rtsSnapshotMaxLiveBytes = 12 + } + +monotoneAfterSnapshot :: RtsSnapshot +monotoneAfterSnapshot = + RtsSnapshot + { rtsSnapshotGcs = 5, + rtsSnapshotMajorGcs = 7, + rtsSnapshotAllocatedBytes = 110, + rtsSnapshotCopiedBytes = 240, + rtsSnapshotMutatorCpuNanoseconds = 350, + rtsSnapshotMutatorElapsedNanoseconds = 460, + rtsSnapshotGcCpuNanoseconds = 570, + rtsSnapshotGcElapsedNanoseconds = 680, + rtsSnapshotCpuNanoseconds = 790, + rtsSnapshotElapsedNanoseconds = 900, + rtsSnapshotLiveBytes = 13, + rtsSnapshotMaxLiveBytes = 14 + } + +expectedMonotoneDelta :: RtsDelta +expectedMonotoneDelta = + RtsDelta + { rtsDeltaGcs = 3, + rtsDeltaMajorGcs = 3, + rtsDeltaAllocatedBytes = 100, + rtsDeltaCopiedBytes = 200, + rtsDeltaMutatorCpuNanoseconds = 300, + rtsDeltaMutatorElapsedNanoseconds = 400, + rtsDeltaGcCpuNanoseconds = 500, + rtsDeltaGcElapsedNanoseconds = 600, + rtsDeltaCpuNanoseconds = 700, + rtsDeltaElapsedNanoseconds = 800 + } + +zeroRtsDelta :: RtsDelta +zeroRtsDelta = + RtsDelta + { rtsDeltaGcs = 0, + rtsDeltaMajorGcs = 0, + rtsDeltaAllocatedBytes = 0, + rtsDeltaCopiedBytes = 0, + rtsDeltaMutatorCpuNanoseconds = 0, + rtsDeltaMutatorElapsedNanoseconds = 0, + rtsDeltaGcCpuNanoseconds = 0, + rtsDeltaGcElapsedNanoseconds = 0, + rtsDeltaCpuNanoseconds = 0, + rtsDeltaElapsedNanoseconds = 0 + } diff --git a/test/compile-diagnostics/CompileDiagnosticsSpec.hs b/test/compile-diagnostics/CompileDiagnosticsSpec.hs new file mode 100644 --- /dev/null +++ b/test/compile-diagnostics/CompileDiagnosticsSpec.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} + +module CompileDiagnosticsSpec + ( tests, + ) +where + +import Data.Aeson (decode, encode) +import Data.List.NonEmpty (NonEmpty (..)) +import Moonlight.Pale.Test.Assertions (expectRightWithLabel) +import Moonlight.Pale.TestSupport.CompileDiagnostics + ( CompileDiagnosticsSession, + CompileFixtureFailure (..), + DiagnosticSnapshot (..), + GhcPackageSpec (..), + NormalizedDiagnostic (..), + SnapshotExit (..), + UnstructuredCompileFailure (..), + compileFixtures, + normalizeSnapshot, + openCompileDiagnosticsSession, + ) +import System.Directory (getCurrentDirectory) +import System.Exit (ExitCode (..)) +import Test.Tasty (TestTree, testGroup, withResource) +import Test.Tasty.HUnit (assertEqual, assertFailure, testCase) + +tests :: TestTree +tests = + withResource acquireCompileContext (const (pure ())) $ \getCompileContext -> + testGroup + "Moonlight.Pale.TestSupport.CompileDiagnostics" + [ testCase "compileFixtures captures a round-trippable clean snapshot" $ + compileTrivialFixture getCompileContext, + testCase "compileFixtures preserves unstructured failures" $ + compileUnstructuredFailure getCompileContext, + testCase "snapshot JSON establishes canonical diagnostic order" $ + assertCanonicalSnapshotRoundTrip + ] + +compileTrivialFixture :: IO (FilePath, CompileDiagnosticsSession) -> IO () +compileTrivialFixture getCompileContext = do + (packageRoot, session) <- getCompileContext + compileResult <- compileFixtures session [] (packageRelativeFixturePath :| []) + fixtureResult <- expectRightWithLabel "compile fixture" compileResult + let snapshot :: DiagnosticSnapshot + snapshot = normalizeSnapshot packageRoot packageRelativeFixturePath fixtureResult + assertEqual "clean fixture exits successfully" SnapshotSuccess (snapshotExit snapshot) + assertEqual "diagnostic snapshot JSON round-trips" (pure snapshot) (roundTripDiagnosticSnapshot snapshot) + +compileUnstructuredFailure :: IO (FilePath, CompileDiagnosticsSession) -> IO () +compileUnstructuredFailure getCompileContext = do + (_, session) <- getCompileContext + compileResult <- + compileFixtures + session + [GhcPackageId "pale-definitely-missing-unit-id"] + (packageRelativeFixturePath :| []) + case compileResult of + Left (CompileFixtureUnstructuredFailure failureValue) -> + case unstructuredCompileExitCode failureValue of + ExitFailure _ -> pure () + ExitSuccess -> assertFailure "unstructured compiler failure cannot report success" + Left otherFailure -> + assertFailure ("expected unstructured compiler failure, got " <> show otherFailure) + Right fixtureResult -> + assertFailure ("expected fixture compilation to fail, got " <> show fixtureResult) + +acquireCompileContext :: IO (FilePath, CompileDiagnosticsSession) +acquireCompileContext = do + packageRoot <- getCurrentDirectory + session <- + expectRightWithLabel "compile diagnostics session" + =<< openCompileDiagnosticsSession packageRoot + pure (packageRoot, session) + +assertCanonicalSnapshotRoundTrip :: IO () +assertCanonicalSnapshotRoundTrip = + assertEqual + "decoded snapshot diagnostics are canonical" + (Just canonicalSnapshot) + (roundTripDiagnosticSnapshot nonCanonicalSnapshot) + where + canonicalSnapshot = + nonCanonicalSnapshot + { snapshotDiagnostics = [alphaDiagnostic, betaDiagnostic] + } + nonCanonicalSnapshot = + DiagnosticSnapshot + { snapshotFixture = "Fixture.hs", + snapshotDiagnosticsFlag = "-fdiagnostics-as-json", + snapshotExit = SnapshotFailure, + snapshotDiagnostics = [betaDiagnostic, alphaDiagnostic] + } + alphaDiagnostic = + NormalizedDiagnostic + { normalizedCode = "GHC-001", + normalizedFile = "Fixture.hs", + normalizedStartLine = 1, + normalizedStartCol = 1, + normalizedEndLine = 1, + normalizedEndCol = 2 + } + betaDiagnostic = + NormalizedDiagnostic + { normalizedCode = "GHC-002", + normalizedFile = "Fixture.hs", + normalizedStartLine = 2, + normalizedStartCol = 1, + normalizedEndLine = 2, + normalizedEndCol = 2 + } + +packageRelativeFixturePath :: FilePath +packageRelativeFixturePath = + "test/compile-diagnostics/fixtures/Trivial.hs" + +roundTripDiagnosticSnapshot :: DiagnosticSnapshot -> Maybe DiagnosticSnapshot +roundTripDiagnosticSnapshot snapshot = + decode (encode snapshot) diff --git a/test/compile-diagnostics/Main.hs b/test/compile-diagnostics/Main.hs new file mode 100644 --- /dev/null +++ b/test/compile-diagnostics/Main.hs @@ -0,0 +1,11 @@ +module Main + ( main, + ) +where + +import CompileDiagnosticsSpec qualified as CompileDiagnosticsSpec +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain (testGroup "pale-diagnostic-ghc" [CompileDiagnosticsSpec.tests]) diff --git a/test/compile-diagnostics/fixtures/Trivial.hs b/test/compile-diagnostics/fixtures/Trivial.hs new file mode 100644 --- /dev/null +++ b/test/compile-diagnostics/fixtures/Trivial.hs @@ -0,0 +1,4 @@ +module Trivial where + +trivial :: () +trivial = () diff --git a/test/diagnostic/CohomologySpec.hs b/test/diagnostic/CohomologySpec.hs new file mode 100644 --- /dev/null +++ b/test/diagnostic/CohomologySpec.hs @@ -0,0 +1,231 @@ +module CohomologySpec + ( tests, + ) +where + +import Moonlight.Pale.Diagnostic.Views.Rewrite + ( RewriteOutcomeSummary (..), + summarizeSaturationTrace, + ) +import Moonlight.Pale.Diagnostic.Summary.Structural + ( GrothendieckStructuralSummary (..), + StructuralSummary (..), + ) +import Moonlight.Pale.Diagnostic.Local.Rewrite + ( RewriteOutcomeStat (..), + RuleTrace (..), + ) +import Moonlight.Pale.Diagnostic.Local.Saturation + ( SaturationIterationTrace (..), + SaturationTrace (..), + ) +import Moonlight.Pale.Diagnostic.Topology.Cohomology + ( CoboundaryNilpotenceEvidence (..), + evidenceNilpotent, + ) +import Moonlight.Pale.Diagnostic.Topology.Homotopy (NerveHomotopyProfile (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) + +data RuleId + = RuleFold + | RuleInline + | RuleSimplify + deriving stock (Eq, Ord, Show) + +tests :: TestTree +tests = + testGroup + "pale.diagnostic.cohomology" + [ testCase "cohomology evidence distinguishes single-context nilpotence from multi-context obstruction" $ do + assertEqual + "single-context nilpotent constructor" + SingleContextNilpotent + knownSingleContextEvidence + assertEqual + "multi-context non-nilpotent constructor" + MultiContextNonNilpotent + knownMultiContextEvidence + assertEqual + "single-context nilpotence predicate" + True + (evidenceNilpotent knownSingleContextEvidence) + assertEqual + "multi-context obstruction predicate" + False + (evidenceNilpotent knownMultiContextEvidence), + testCase "global structural summary folds cohomology and homotopy evidence into record shape" $ + assertEqual + "structural summary shape" + expectedStructuralSummary + (structuralSummaryFromGrothendieck knownGrothendieckSummary), + testCase "derived rewrite summary ranks worked trace structure" $ + assertEqual + "rewrite rule rank" + [RuleInline, RuleFold, RuleSimplify] + (rosRuleId <$> rosRuleStats workedRewriteSummary) + ] + +knownSingleContextEvidence :: CoboundaryNilpotenceEvidence +knownSingleContextEvidence = + SingleContextNilpotent + +knownMultiContextEvidence :: CoboundaryNilpotenceEvidence +knownMultiContextEvidence = + MultiContextNonNilpotent + +knownHomotopyProfile :: NerveHomotopyProfile +knownHomotopyProfile = + NerveHomotopyProfile + { nhpConnectedComponents = 1, + nhpBettiVector = [1, 0] + } + +knownGrothendieckSummary :: GrothendieckStructuralSummary +knownGrothendieckSummary = + GrothendieckStructuralSummary + { gssHomotopyProfile = knownHomotopyProfile, + gssCellCount = 4, + gssFaceCount = 3, + gssObjectCount = 2, + gssMorphismCount = 5, + gssCrossContextMorphismCount = 2, + gssVerticalMorphismCount = 2, + gssDiagonalMorphismCount = 1, + gssCoboundaryNilpotenceEvidence = knownSingleContextEvidence + } + +expectedStructuralSummary :: StructuralSummary +expectedStructuralSummary = + StructuralSummary + { ssConnectedComponents = 1, + ssBettiNumbers = [1, 0], + ssCellCount = 4, + ssRestrictionCount = 5, + ssCoboundaryNilpotent = True, + ssMicrosupportSize = Just 2, + ssCriticalCellCount = Just 2, + ssNoncriticalFraction = Nothing + } + +structuralSummaryFromGrothendieck :: GrothendieckStructuralSummary -> StructuralSummary +structuralSummaryFromGrothendieck summary = + StructuralSummary + { ssConnectedComponents = nhpConnectedComponents (gssHomotopyProfile summary), + ssBettiNumbers = nhpBettiVector (gssHomotopyProfile summary), + ssCellCount = gssCellCount summary, + ssRestrictionCount = gssMorphismCount summary, + ssCoboundaryNilpotent = evidenceNilpotent (gssCoboundaryNilpotenceEvidence summary), + ssMicrosupportSize = Just (gssObjectCount summary), + ssCriticalCellCount = Just (gssCrossContextMorphismCount summary), + ssNoncriticalFraction = Nothing + } + +workedTrace :: SaturationTrace RuleId +workedTrace = + SaturationTrace + { stIterations = + [ firstIterationTrace, + secondIterationTrace + ] + } + +workedRewriteSummary :: RewriteOutcomeSummary RuleId +workedRewriteSummary = + summarizeSaturationTrace workedTrace + +firstIterationTrace :: SaturationIterationTrace RuleId +firstIterationTrace = + SaturationIterationTrace + { sitIteration = 0, + sitNodeCountBefore = 2, + sitNodeCountAfter = 4, + sitBaseEligibleCount = 3, + sitContextEligibleCount = 2, + sitAggregatedEligibleCount = 3, + sitGuidedCount = 2, + sitScheduledCount = 4, + sitFactsChanged = True, + sitFactRoundCount = 1, + sitContextRevision = 0, + sitRuleTraces = + [ foldTraceInitial, + inlineTraceInitial + ] + } + +secondIterationTrace :: SaturationIterationTrace RuleId +secondIterationTrace = + SaturationIterationTrace + { sitIteration = 1, + sitNodeCountBefore = 4, + sitNodeCountAfter = 5, + sitBaseEligibleCount = 2, + sitContextEligibleCount = 2, + sitAggregatedEligibleCount = 2, + sitGuidedCount = 1, + sitScheduledCount = 4, + sitFactsChanged = False, + sitFactRoundCount = 2, + sitContextRevision = 1, + sitRuleTraces = + [ inlineTraceFollowup, + simplifyTraceFiltered, + foldTraceBanned + ] + } + +foldTraceInitial :: RuleTrace RuleId +foldTraceInitial = + RuleTrace + { rtRuleId = RuleFold, + rtMatchedCount = 5, + rtFilteredCount = 1, + rtScheduledCount = 3, + rtSkippedByScheduler = False, + rtBannedUntil = Nothing + } + +inlineTraceInitial :: RuleTrace RuleId +inlineTraceInitial = + RuleTrace + { rtRuleId = RuleInline, + rtMatchedCount = 2, + rtFilteredCount = 1, + rtScheduledCount = 1, + rtSkippedByScheduler = False, + rtBannedUntil = Nothing + } + +inlineTraceFollowup :: RuleTrace RuleId +inlineTraceFollowup = + RuleTrace + { rtRuleId = RuleInline, + rtMatchedCount = 4, + rtFilteredCount = 0, + rtScheduledCount = 4, + rtSkippedByScheduler = False, + rtBannedUntil = Nothing + } + +simplifyTraceFiltered :: RuleTrace RuleId +simplifyTraceFiltered = + RuleTrace + { rtRuleId = RuleSimplify, + rtMatchedCount = 3, + rtFilteredCount = 3, + rtScheduledCount = 0, + rtSkippedByScheduler = False, + rtBannedUntil = Nothing + } + +foldTraceBanned :: RuleTrace RuleId +foldTraceBanned = + RuleTrace + { rtRuleId = RuleFold, + rtMatchedCount = 1, + rtFilteredCount = 1, + rtScheduledCount = 0, + rtSkippedByScheduler = True, + rtBannedUntil = Just 3 + } diff --git a/test/diagnostic/Main.hs b/test/diagnostic/Main.hs new file mode 100644 --- /dev/null +++ b/test/diagnostic/Main.hs @@ -0,0 +1,13 @@ +module Main + ( main, + ) +where + +import CohomologySpec qualified as CohomologySpec +import OutcomeSpec qualified as OutcomeSpec +import RefinementSpec qualified as RefinementSpec +import WriterSpec qualified as WriterSpec +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = defaultMain (testGroup "pale-diagnostic" [WriterSpec.tests, OutcomeSpec.tests, RefinementSpec.tests, CohomologySpec.tests]) diff --git a/test/diagnostic/OutcomeSpec.hs b/test/diagnostic/OutcomeSpec.hs new file mode 100644 --- /dev/null +++ b/test/diagnostic/OutcomeSpec.hs @@ -0,0 +1,199 @@ +module OutcomeSpec + ( tests, + ) +where + +import Data.Foldable (traverse_) +import Data.List (sortOn) +import Data.Map.Strict qualified as Map +import Data.Ord (Down (..)) +import Data.Sequence qualified as Seq +import Data.Set qualified as Set +import Moonlight.Pale.Diagnostic.Aggregation.Algebra + ( OutcomeSummary, + outcomeSummaryDiagnostics, + outcomeSummaryFromProjectionOutcome, + outcomeSummaryFromRestrictionOutcome, + outcomeSummaryRestrictionOutcomes, + restrictionIndexByCell, + restrictionIndexByMismatch, + restrictionIndexFromOutcomes, + restrictionIndexStats, + restrictionIndexTotal, + topRestrictionHotspots, + ) +import Moonlight.Pale.Diagnostic.Local.Propagation + ( ProjectionRunOutcome (..), + RestrictionOutcomeStat (..), + RestrictionRunOutcome (..), + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) + +type Cell = String + +type ProjectionKey = String + +type ProjectionValue = String + +type ProjectionFailure = String + +type Diagnostic = String + +data Mismatch + = ContextMismatch + | PhaseMismatch + | ShapeMismatch + deriving stock (Eq, Ord, Show) + +tests :: TestTree +tests = + testGroup + "pale.diagnostic.outcome" + [ testCase "OutcomeSummary has mempty as a left identity" $ + assertEqual + "left identity" + outcomeSummaryA + (mempty <> outcomeSummaryA), + testCase "OutcomeSummary has mempty as a right identity" $ + assertEqual + "right identity" + outcomeSummaryA + (outcomeSummaryA <> mempty), + testCase "OutcomeSummary composition is associative" $ + assertEqual + "associativity" + ((outcomeSummaryA <> outcomeSummaryB) <> outcomeSummaryC) + (outcomeSummaryA <> (outcomeSummaryB <> outcomeSummaryC)), + testCase "OutcomeSummary preserves diagnostic and restriction order" $ + let summary = outcomeSummaryA <> outcomeSummaryC <> outcomeSummaryC + in do + assertEqual + "diagnostics" + (Seq.singleton "alpha adjusted") + (outcomeSummaryDiagnostics summary) + assertEqual + "restrictions" + (Seq.fromList [restrictionC, restrictionC]) + (outcomeSummaryRestrictionOutcomes summary), + testCase "one restriction index derives every aggregate view" $ + let restrictionIndex = restrictionIndexFromOutcomes knownRestrictionOutcomes + in do + assertEqual "total" 6 (restrictionIndexTotal restrictionIndex) + assertEqual + "mismatch counts" + [(ContextMismatch, 1), (PhaseMismatch, 3), (ShapeMismatch, 2)] + (Map.toAscList (restrictionIndexByMismatch restrictionIndex)) + assertEqual + "cell counts" + [("alpha", 3), ("beta", 2), ("gamma", 1), ("omega", 6)] + (Map.toAscList (restrictionIndexByCell restrictionIndex)) + assertEqual + "ranked hotspot structure" + [ ("alpha", "omega", PhaseMismatch), + ("beta", "omega", ShapeMismatch) + ] + (hotspotKey <$> topRestrictionHotspots 2 restrictionIndex), + testCase "bounded hotspots equal the stable full-sort reference for every limit" $ + let restrictionIndex = restrictionIndexFromOutcomes differentialRestrictionOutcomes + stableFullSort = + sortOn + (Down . rosOccurrences) + (restrictionIndexStats restrictionIndex) + limits = [-2 .. length stableFullSort + 2] + in traverse_ + ( \limitValue -> + assertEqual + ("limit " <> show limitValue) + (take (max 0 limitValue) stableFullSort) + (topRestrictionHotspots limitValue restrictionIndex) + ) + limits, + testCase "hotspot benchmark matrix matches the stable full-sort reference" $ + traverse_ + assertHotspotMatrixAgreement + hotspotBenchmarkScales + ] + +outcomeSummaryA :: OutcomeSummary Cell Mismatch ProjectionKey ProjectionValue ProjectionFailure Diagnostic +outcomeSummaryA = + outcomeSummaryFromProjectionOutcome projectionAppliedA + +outcomeSummaryB :: OutcomeSummary Cell Mismatch ProjectionKey ProjectionValue ProjectionFailure Diagnostic +outcomeSummaryB = + outcomeSummaryFromProjectionOutcome projectionSkippedB + +outcomeSummaryC :: OutcomeSummary Cell Mismatch ProjectionKey ProjectionValue ProjectionFailure Diagnostic +outcomeSummaryC = + outcomeSummaryFromRestrictionOutcome restrictionC + +projectionAppliedA :: ProjectionRunOutcome Cell ProjectionKey ProjectionValue ProjectionFailure Diagnostic +projectionAppliedA = + ProjectionApplied + "project-alpha" + (Set.fromList ["alpha", "beta"]) + "projected" + 0.25 + (Seq.singleton "alpha adjusted") + +projectionSkippedB :: ProjectionRunOutcome Cell ProjectionKey ProjectionValue ProjectionFailure Diagnostic +projectionSkippedB = + ProjectionSkipped "project-beta" "already stable" + +restrictionC :: RestrictionRunOutcome Cell Mismatch +restrictionC = + RestrictionMismatch "beta" "omega" [ShapeMismatch] + +knownRestrictionOutcomes :: [RestrictionRunOutcome Cell Mismatch] +knownRestrictionOutcomes = + [ RestrictionMismatch "alpha" "omega" [PhaseMismatch, PhaseMismatch, PhaseMismatch], + RestrictionMismatch "beta" "omega" [ShapeMismatch, ShapeMismatch], + RestrictionMismatch "gamma" "omega" [ContextMismatch] + ] + +differentialRestrictionOutcomes :: [RestrictionRunOutcome Cell Mismatch] +differentialRestrictionOutcomes = + [ RestrictionMismatch "alpha" "omega" [PhaseMismatch, PhaseMismatch], + RestrictionMismatch "beta" "omega" [ShapeMismatch, ShapeMismatch, ShapeMismatch], + RestrictionMismatch "gamma" "omega" [ContextMismatch, ContextMismatch, ContextMismatch], + RestrictionMismatch "delta" "omega" [PhaseMismatch], + RestrictionMismatch "epsilon" "omega" [ShapeMismatch, ShapeMismatch] + ] + +hotspotBenchmarkScales :: [(Int, [Int])] +hotspotBenchmarkScales = + [ (2048, [1, 16, 45, 1023, 1024, 2048]), + (16384, [1, 16, 128, 8191, 8192, 16384]), + (65536, [1, 16, 256, 32767, 32768, 65536]) + ] + +assertHotspotMatrixAgreement :: (Int, [Int]) -> IO () +assertHotspotMatrixAgreement (uniqueAtomCount, hotspotCounts) = + let restrictionIndex = + restrictionIndexFromOutcomes + (rankedRestrictionOutcomes uniqueAtomCount) + stableFullSort = + sortOn + (Down . rosOccurrences) + (restrictionIndexStats restrictionIndex) + in traverse_ + ( \hotspotCount -> + assertEqual + ("K=" <> show uniqueAtomCount <> ", k=" <> show hotspotCount) + (take hotspotCount stableFullSort) + (topRestrictionHotspots hotspotCount restrictionIndex) + ) + hotspotCounts + +rankedRestrictionOutcomes :: Int -> [RestrictionRunOutcome Int Int] +rankedRestrictionOutcomes count = + [ RestrictionMismatch + index + (index + 1) + (replicate (1 + (index `mod` 7)) index) + | index <- [1 .. count] + ] + +hotspotKey :: RestrictionOutcomeStat Cell Mismatch -> (Cell, Cell, Mismatch) +hotspotKey stat = + (rosSourceCell stat, rosTargetCell stat, rosMismatch stat) diff --git a/test/diagnostic/RefinementSpec.hs b/test/diagnostic/RefinementSpec.hs new file mode 100644 --- /dev/null +++ b/test/diagnostic/RefinementSpec.hs @@ -0,0 +1,96 @@ +module RefinementSpec + ( tests, + ) +where + +import Moonlight.Pale.Diagnostic.Local.Replay + ( Nanoseconds, + NonNegativeCount, + RateNonFiniteValue (..), + ReplayDiagnosticsValidationError (..), + diffNonNegativeCount, + mkNanoseconds, + mkNonNegativeCount, + mkRate, + nanosecondsFromNatural, + nonNegativeCountFromNatural, + rateFromCounts, + rateValue, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) + +tests :: TestTree +tests = + testGroup + "pale.diagnostic.refinement" + [ testCase "mkNonNegativeCount rejects negative counts and accepts valid counts" $ do + assertEqual + "negative count rejection" + (Left (NegativeCount (-1))) + (mkNonNegativeCount (-1)) + assertEqual + "valid count acceptance" + (Right validCount) + (mkNonNegativeCount 3), + testCase "mkNanoseconds rejects negative durations and accepts valid durations" $ do + assertEqual + "negative nanoseconds rejection" + (Left (NegativeNanoseconds (-8))) + (mkNanoseconds (-8)) + assertEqual + "valid nanoseconds acceptance" + (Right validNanoseconds) + (mkNanoseconds 13), + testCase "mkRate rejects invalid rates and accepts valid rates" $ do + assertEqual + "infinite rate rejection" + (Left (NonFiniteRate RateInfinite)) + (mkRate infiniteRateInput) + assertEqual + "out of bounds rate rejection" + (Left (RateOutOfBounds 1.25)) + (mkRate 1.25) + assertEqual + "valid rate acceptance" + (Right 0.5) + (rateValue <$> mkRate 0.5), + testCase "rateFromCounts rejects invalid ratios and accepts valid ratios" $ do + assertEqual + "zero denominator rejection" + (Left RateDenominatorZero) + (rateFromCounts validCount zeroCount) + assertEqual + "numerator greater than denominator rejection" + (Left (RateNumeratorExceedsDenominator validCount smallerCount)) + (rateFromCounts validCount smallerCount) + assertEqual + "valid ratio acceptance" + (Right (1 / 3)) + (rateValue <$> rateFromCounts smallerCount validCount), + testCase "diffNonNegativeCount rejects underflow without wrapping" $ + assertEqual + "underflowing count difference" + (Left (CountDifferenceUnderflow smallerCount validCount)) + (diffNonNegativeCount smallerCount validCount) + ] + +zeroCount :: NonNegativeCount +zeroCount = + nonNegativeCountFromNatural 0 + +smallerCount :: NonNegativeCount +smallerCount = + nonNegativeCountFromNatural 1 + +validCount :: NonNegativeCount +validCount = + nonNegativeCountFromNatural 3 + +validNanoseconds :: Nanoseconds +validNanoseconds = + nanosecondsFromNatural 13 + +infiniteRateInput :: Double +infiniteRateInput = + 1 / 0 diff --git a/test/diagnostic/WriterSpec.hs b/test/diagnostic/WriterSpec.hs new file mode 100644 --- /dev/null +++ b/test/diagnostic/WriterSpec.hs @@ -0,0 +1,72 @@ +module WriterSpec + ( tests, + ) +where + +import Moonlight.Pale.Diagnostic.Core + ( Diagnosed, + DiagnosticSeverity (..), + emitDiagnostic, + filterBySeverity, + pureDiagnosed, + runDiagnosed, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) + +data WriterNote = WriterNote + { writerNoteSeverity :: DiagnosticSeverity, + writerNoteMessage :: String + } + deriving stock (Eq, Show) + +tests :: TestTree +tests = + testGroup + "pale.diagnostic.writer" + [ testCase "runDiagnosed returns the value and emitted notes in emission order" $ + assertEqual + "diagnosed writer result" + ("accepted", [infoNote, warningNote, errorNote]) + (runDiagnosed workedDiagnosed), + testCase "filterBySeverity keeps notes at or above the threshold" $ + assertEqual + "severity-filtered notes" + [warningNote, errorNote] + (filterBySeverity writerNoteSeverity DiagWarning writerNotes) + ] + +workedDiagnosed :: Diagnosed WriterNote String +workedDiagnosed = + emitDiagnostic infoNote + *> emitDiagnostic warningNote + *> emitDiagnostic errorNote + *> pureDiagnosed "accepted" + +writerNotes :: [WriterNote] +writerNotes = + [ infoNote, + warningNote, + errorNote + ] + +infoNote :: WriterNote +infoNote = + WriterNote + { writerNoteSeverity = DiagInfo, + writerNoteMessage = "local section observed" + } + +warningNote :: WriterNote +warningNote = + WriterNote + { writerNoteSeverity = DiagWarning, + writerNoteMessage = "overlap pending" + } + +errorNote :: WriterNote +errorNote = + WriterNote + { writerNoteSeverity = DiagError, + writerNoteMessage = "gluing obstruction" + } diff --git a/test/ghc-surface/Expr/RenderRoundTripSpec.hs b/test/ghc-surface/Expr/RenderRoundTripSpec.hs new file mode 100644 --- /dev/null +++ b/test/ghc-surface/Expr/RenderRoundTripSpec.hs @@ -0,0 +1,2665 @@ +{-# LANGUAGE LambdaCase #-} + +module Expr.RenderRoundTripSpec + ( tests, + ) +where + +import Data.ByteString qualified as ByteString +import Data.Either (partitionEithers) +import Data.Foldable (traverse_) +import Data.Graph (SCC (..), stronglyConnComp) +import Data.List (find, isInfixOf) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import GHC.Types.Name.Occurrence (mkDataOcc, mkVarOcc, occNameString) +import GHC.Types.Name.Reader (RdrName, mkRdrUnqual, rdrNameOcc) +import Moonlight.Core (BinderId (..), Pattern (..)) +import Moonlight.Core qualified as EGraph +import Moonlight.Pale.Ghc.Expr +import Moonlight.Pale.Test.Assertions (expectRightWithLabel) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Vector qualified as Vector +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "pale.expr" + [ renderRoundTripTests, + declarationOrderTests, + typedUnsupportedSyntaxTests, + spanLockstepTests, + scopeIndexTests, + caseAlternativeScopeTests + ] + +renderSourceString :: + LayoutPolicy -> + RenderTarget -> + Either RenderRefusal String +renderSourceString layoutPolicy = + fmap Text.unpack . renderSource layoutPolicy + +renderFixtureModule :: + String -> + ConvertedModule -> + Either RenderRefusal String +renderFixtureModule moduleName = + renderSourceString + CompactLayout + . RenderConvertedModule (ModuleRenderContext "" (Just moduleName)) + +data DeclarationKind + = ValueDeclarationKind + | TypeSignatureDeclarationKind + | FixityDeclarationKind + | InstanceDeclarationKind + | OpaqueDeclarationKind + deriving stock (Eq, Show) + +data ExpressionMetricOracle = ExpressionMetricOracle + { oracleScopedExprCount :: !Int, + oracleGlobalVarRefCount :: !Int, + oracleLocalVarRefCount :: !Int, + oracleMaxFreeScopeCount :: !Int + } + deriving stock (Eq, Show) + +instance Semigroup ExpressionMetricOracle where + leftMetrics <> rightMetrics = + ExpressionMetricOracle + { oracleScopedExprCount = + oracleScopedExprCount leftMetrics + oracleScopedExprCount rightMetrics, + oracleGlobalVarRefCount = + oracleGlobalVarRefCount leftMetrics + oracleGlobalVarRefCount rightMetrics, + oracleLocalVarRefCount = + oracleLocalVarRefCount leftMetrics + oracleLocalVarRefCount rightMetrics, + oracleMaxFreeScopeCount = + max + (oracleMaxFreeScopeCount leftMetrics) + (oracleMaxFreeScopeCount rightMetrics) + } + +instance Monoid ExpressionMetricOracle where + mempty = + ExpressionMetricOracle + { oracleScopedExprCount = 0, + oracleGlobalVarRefCount = 0, + oracleLocalVarRefCount = 0, + oracleMaxFreeScopeCount = 0 + } + +declarationKind :: ModuleDeclaration -> DeclarationKind +declarationKind = \case + ValueDeclaration _ -> ValueDeclarationKind + TypeSignatureDeclaration _ -> TypeSignatureDeclarationKind + FixityDeclarationNode _ -> FixityDeclarationKind + InstanceDeclarationNode _ -> InstanceDeclarationKind + OpaqueDeclaration {} -> OpaqueDeclarationKind + +declarationOrderTests :: TestTree +declarationOrderTests = + testGroup + "pale.declarations" + [ testCase "conversion and rendering preserve supported declaration order" $ do + let sourceText = + unlines + [ "module DeclarationOrder where", + "before :: Int -> Int", + "before value = value", + "infixr 5 <+>", + "(<+>) :: Int -> Int -> Int", + "left <+> right = left + right" + ] + expectedOrder = + [ TypeSignatureDeclarationKind, + ValueDeclarationKind, + FixityDeclarationKind, + TypeSignatureDeclarationKind, + ValueDeclarationKind + ] + convertedModule <- + expectRightWithLabel + "ordered declaration conversion" + (convertHaskellSource "DeclarationOrder.hs" sourceText) + fmap declarationKind (Vector.toList (cmDeclarations convertedModule)) + @?= expectedOrder + length (convertedModuleBindings convertedModule) @?= 2 + length (convertedModuleTypeSignatures convertedModule) @?= 2 + length (convertedModuleFixityDeclarations convertedModule) @?= 1 + renderedSource <- + expectRightWithLabel + "ordered declaration rendering" + ( renderSourceString + CompactLayout + ( RenderConvertedModule + (ModuleRenderContext "" (Just "DeclarationOrder")) + convertedModule + ) + ) + reparsedModule <- + expectRightWithLabel + ("ordered declaration re-parse:\n" <> renderedSource) + (convertHaskellSource "DeclarationOrder.hs" renderedSource) + fmap declarationKind (Vector.toList (cmDeclarations reparsedModule)) + @?= expectedOrder, + testCase "class instances expose traversable methods while exact source remains authoritative" $ do + let instanceSource = + unlines + [ "module OpaqueDeclarations where", + "type Alias = Int", + "data Box = Box { unBox :: Int }", + "instance Show Box where", + " show box = box" + ] + convertedModule <- + expectRightWithLabel + "instance declaration conversion" + (convertHaskellSource "OpaqueDeclarations.hs" instanceSource) + fmap declarationKind (Vector.toList (cmDeclarations convertedModule)) + @?= [OpaqueDeclarationKind, OpaqueDeclarationKind, InstanceDeclarationKind] + case Vector.toList (cmDeclarations convertedModule) of + [ OpaqueDeclaration typeTag _ typeSource, + OpaqueDeclaration dataTag _ dataSource, + InstanceDeclarationNode convertedInstance + ] -> do + typeTag @?= UnsupportedTypeOrClassDeclaration + dataTag @?= UnsupportedTypeOrClassDeclaration + typeSource @?= "type Alias = Int" + dataSource @?= "data Box = Box { unBox :: Int }" + convertedInstanceSource convertedInstance + @?= "instance Show Box where\n show box = box" + srStartLine (convertedInstanceRegion convertedInstance) @?= 4 + case convertedInstanceMethods convertedInstance of + [TraversableInstanceMethod methodBinding] -> do + fmap srStartLine (tlbRegion methodBinding) @?= Just 5 + fmap + (occNameString . rdrNameOcc) + (bindingNames (tlbBinding methodBinding)) + @?= ["show"] + methodSections -> + assertFailure + ("expected one traversable instance method, got " <> show methodSections) + _ -> + assertFailure "expected two opaque declarations and one instance node" + convertedModuleBindings convertedModule @?= [] + convertedModuleInstanceMethodObstructions convertedModule @?= [] + case convertedModuleBindingSites convertedModule of + [ConvertedBindingSite (InstanceMethodBindingOrigin originRegion) methodBinding] -> do + srStartLine originRegion @?= 4 + fmap srStartLine (tlbRegion methodBinding) @?= Just 5 + bindingSites -> + assertFailure + ("expected one origin-tagged instance method site, got " <> show bindingSites) + let metrics = convertedModuleMetrics convertedModule + cmmBindingCount metrics @?= 0 + cmmInstanceDeclarationCount metrics @?= 1 + cmmTraversableInstanceMethodCount metrics @?= 1 + cmmObstructedInstanceMethodCount metrics @?= 0 + renderedModule <- + expectRightWithLabel + "instance declaration rendering" + ( renderSourceString + CompactLayout + ( RenderConvertedModule + (ModuleRenderContext "" (Just "OpaqueDeclarations")) + convertedModule + ) + ) + assertBool + "type, data, and class instance declarations retain their exact source" + ( "type Alias = Int" `isInfixOf` renderedModule + && "data Box = Box { unBox :: Int }" `isInfixOf` renderedModule + && "instance Show Box where\n show box = box" `isInfixOf` renderedModule + ) + reparsedModule <- + expectRightWithLabel + "rendered instance reparse" + (convertHaskellSource "OpaqueDeclarations.hs" renderedModule) + case Vector.toList (cmDeclarations reparsedModule) of + [_, _, InstanceDeclarationNode reparsedInstance] -> + convertedInstanceSource reparsedInstance + @?= convertedInstanceSource + ( case Vector.toList (cmDeclarations convertedModule) of + [_, _, InstanceDeclarationNode originalInstance] -> + originalInstance + _ -> + reparsedInstance + ) + declarations -> + assertFailure + ("expected reparsed instance declaration, got " <> show declarations), + testCase "binding sites preserve declaration and method source order without widening top-level bindings" $ do + let sourceText = + unlines + [ "module MixedBindingSites where", + "before = 1", + "instance Example Item where", + " method value = value", + "after = 2" + ] + convertedModule <- + expectRightWithLabel + "mixed binding-site conversion" + (convertHaskellSource "MixedBindingSites.hs" sourceText) + fmap declarationKind (Vector.toList (cmDeclarations convertedModule)) + @?= [ValueDeclarationKind, InstanceDeclarationKind, ValueDeclarationKind] + fmap + (fmap (occNameString . rdrNameOcc) . bindingNames . tlbBinding) + (convertedModuleBindings convertedModule) + @?= [["before"], ["after"]] + case convertedModuleBindingSites convertedModule of + [ ConvertedBindingSite TopLevelBindingOrigin beforeBinding, + ConvertedBindingSite (InstanceMethodBindingOrigin instanceRegion) methodBinding, + ConvertedBindingSite TopLevelBindingOrigin afterBinding + ] -> do + fmap srStartLine (tlbRegion beforeBinding) @?= Just 2 + srStartLine instanceRegion @?= 3 + fmap srStartLine (tlbRegion methodBinding) @?= Just 4 + fmap srStartLine (tlbRegion afterBinding) @?= Just 5 + bindingSites -> + assertFailure + ("expected ordered top-level and instance binding sites, got " <> show bindingSites), + testCase "empty class instances are exact valid nodes" $ do + convertedModule <- + expectRightWithLabel + "empty instance conversion" + ( convertHaskellSource + "EmptyInstance.hs" + (unlines ["module EmptyInstance where", "instance Empty Item"]) + ) + case Vector.toList (cmDeclarations convertedModule) of + [InstanceDeclarationNode convertedInstance] -> do + convertedInstanceSource convertedInstance @?= "instance Empty Item" + convertedInstanceMethods convertedInstance @?= [] + declarations -> + assertFailure ("expected one empty instance node, got " <> show declarations), + testCase "type-family and data-family instances retain exact source under precise tags" $ do + convertedModule <- + expectRightWithLabel + "family instance conversion" + ( convertHaskellSource + "FamilyInstances.hs" + ( unlines + [ "{-# LANGUAGE TypeFamilies #-}", + "module FamilyInstances where", + "type family Family value", + "type instance Family Int = Bool", + "data family FamilyData value", + "data instance FamilyData Int = FamilyDataInt" + ] + ) + ) + case Vector.toList (cmDeclarations convertedModule) of + [ OpaqueDeclaration typeFamilyTag _ typeFamilySource, + OpaqueDeclaration typeInstanceTag _ typeInstanceSource, + OpaqueDeclaration dataFamilyTag _ dataFamilySource, + OpaqueDeclaration dataInstanceTag _ dataInstanceSource + ] -> do + typeFamilyTag @?= UnsupportedTypeOrClassDeclaration + typeInstanceTag @?= UnsupportedTypeFamilyInstanceDeclaration + dataFamilyTag @?= UnsupportedTypeOrClassDeclaration + dataInstanceTag @?= UnsupportedDataFamilyInstanceDeclaration + typeFamilySource @?= "type family Family value" + typeInstanceSource @?= "type instance Family Int = Bool" + dataFamilySource @?= "data family FamilyData value" + dataInstanceSource @?= "data instance FamilyData Int = FamilyDataInt" + declarations -> + assertFailure + ("expected four exact family declaration rows, got " <> show declarations), + testCase "instance method conversion rolls back recoverable syntax without erasing siblings" $ do + convertedModule <- + expectRightWithLabel + "recoverable instance method conversion" + ( convertHaskellSource + "RecoverableInstanceMethod.hs" + ( unlines + [ "{-# LANGUAGE ViewPatterns #-}", + "module RecoverableInstanceMethod where", + "instance Example Item where", + " first x = x", + " bad (project -> y) = y", + " third z = z" + ] + ) + ) + case Vector.toList (cmDeclarations convertedModule) of + [InstanceDeclarationNode convertedInstance] -> + case convertedInstanceMethods convertedInstance of + [ TraversableInstanceMethod firstBinding, + ObstructedInstanceMethod methodObstruction, + TraversableInstanceMethod thirdBinding + ] -> do + fmap srStartLine (tlbRegion firstBinding) @?= Just 4 + fmap srStartLine (instanceMethodObstructionRegion methodObstruction) @?= Just 5 + fmap srStartLine (tlbRegion thirdBinding) @?= Just 6 + case instanceMethodObstructionCause methodObstruction of + InstanceMethodUnsupportedPattern (Just obstructionRegion) PatOpaqueView -> + srStartLine obstructionRegion @?= 5 + obstructionCause -> + assertFailure + ("expected a region-bearing view-pattern cause, got " <> show obstructionCause) + case (tlbBinding firstBinding, tlbBinding thirdBinding) of + ( FunctionBinding firstHead (Clause [PVarP firstArgument] _ :| []), + FunctionBinding thirdHead (Clause [PVarP thirdArgument] _ :| []) + ) -> + fmap baId [firstHead, firstArgument, thirdHead, thirdArgument] + @?= [BinderId 0, BinderId 1, BinderId 2, BinderId 3] + bindingPair -> + assertFailure + ("expected two single-argument function bindings, got " <> show bindingPair) + methodSections -> + assertFailure + ("expected traversable/obstructed/traversable method order, got " <> show methodSections) + declarations -> + assertFailure ("expected one instance node, got " <> show declarations) + fmap baId (cmLambdaSites convertedModule) @?= [BinderId 1, BinderId 3] + convertedModuleBindings convertedModule @?= [] + length (convertedModuleBindingSites convertedModule) @?= 2 + length (convertedModuleInstanceMethodObstructions convertedModule) @?= 1 + let metrics = convertedModuleMetrics convertedModule + cmmBindingCount metrics @?= 0 + cmmInstanceDeclarationCount metrics @?= 1 + cmmTraversableInstanceMethodCount metrics @?= 2 + cmmObstructedInstanceMethodCount metrics @?= 1, + testCase "instance recovery classifier rejects invariant failures" $ do + recoverableInstanceMethodObstruction + Nothing + (ConvertMissingScopeDepth rootScopeId) + @?= Nothing + assertBool + "unsupported expression syntax must remain recoverable inside one method" + ( case + recoverableInstanceMethodObstruction + Nothing + (ConvertUnsupportedExpression Nothing OpaqueStatic) + of + Just _ -> + True + Nothing -> + False + ) + ] + +typedUnsupportedSyntaxTests :: TestTree +typedUnsupportedSyntaxTests = + testGroup + "pale.typed-unsupported-syntax" + [ testCase "parallel statements retain their exact refusal" $ + assertUnsupportedExpressionTag + "ParallelStatement.hs" + ( unlines + [ "{-# LANGUAGE ParallelListComp #-}", + "module ParallelStatement where", + "parallel left right = [x + y | x <- left | y <- right]" + ] + ) + OpaqueParallelStatement, + testCase "transform statements retain their exact refusal" $ + assertUnsupportedExpressionTag + "TransformStatement.hs" + ( unlines + [ "{-# LANGUAGE TransformListComp #-}", + "module TransformStatement where", + "import GHC.Exts (groupWith)", + "grouped values = [value | value <- values, then group by value using groupWith]" + ] + ) + OpaqueTransformStatement, + testCase "recursive statements retain their exact refusal" $ + assertUnsupportedExpressionTag + "RecursiveStatement.hs" + ( unlines + [ "{-# LANGUAGE RecursiveDo #-}", + "module RecursiveStatement where", + "recursive action = mdo { rec { value <- action value }; pure value }" + ] + ) + OpaqueRecursiveStatement, + testCase "implicit-parameter binds retain their exact refusal" $ + assertUnsupportedExpressionTag + "ImplicitParameter.hs" + ( unlines + [ "{-# LANGUAGE ImplicitParams #-}", + "module ImplicitParameter where", + "parameter value = let ?parameter = value in ?parameter" + ] + ) + OpaqueImplicitParameterBinds, + testCase "overloaded record updates retain their exact refusal" $ + assertUnsupportedExpressionTag + "OverloadedRecordUpdate.hs" + ( unlines + [ "{-# LANGUAGE OverloadedRecordDot #-}", + "{-# LANGUAGE OverloadedRecordUpdate #-}", + "module OverloadedRecordUpdate where", + "rename recordValue = recordValue { owner.name = \"Ada\" }" + ] + ) + OpaqueOverloadedRecordUpdate + ] + +assertUnsupportedExpressionTag :: + FilePath -> + String -> + HsOpaqueTag -> + IO () +assertUnsupportedExpressionTag sourcePath sourceText expectedTag = + case convertHaskellSource sourcePath sourceText of + Left (ConvertUnsupportedExpression (Just _) actualTag) -> + actualTag @?= expectedTag + Left obstruction -> + assertFailure + ( "expected a region-bearing " + <> show expectedTag + <> " obstruction, got " + <> show obstruction + ) + Right _ -> + assertFailure + ("expected a region-bearing " <> show expectedTag <> " obstruction, got success") + +scopeIndexTests :: TestTree +scopeIndexTests = + testGroup + "pale.scope-index" + [ testCase "all valid preorder parent vectors through size eight agree with the parent-walk oracle" $ do + let (rejectedParentVectors, validScopeIndexes) = scopeParentVectorPartition + length scopeParentVectorCandidates @?= 5914 + length rejectedParentVectors @?= 5288 + length validScopeIndexes @?= 626 + case + find + ( \(parentVector, scopeIndex) -> + case verifyScopeIndexAgainstParentWalk parentVector scopeIndex of + Left _ -> + True + Right () -> + False + ) + validScopeIndexes + of + Nothing -> + pure () + Just (parentVector, scopeIndex) -> + case verifyScopeIndexAgainstParentWalk parentVector scopeIndex of + Left failure -> + assertFailure + ( failure + <> "\nparent vector: " + <> show (Vector.toList parentVector) + ) + Right () -> + assertFailure "scope differential reported a non-reproducible failure", + testCase "a preorder chain has its deepest scope as O(1) top" $ do + scopeIndex <- + expectRightWithLabel + "chain scope index" + (mkScopeIndex (Vector.fromList [0, 0, 1, 2]) Vector.empty) + scopeOne <- expectRightWithLabel "scope one" (mkScopeId 1) + scopeTwo <- expectRightWithLabel "scope two" (mkScopeId 2) + scopeThree <- expectRightWithLabel "scope three" (mkScopeId 3) + scopeTopCtx scopeIndex @?= Right (ActualScope scopeThree) + scopeIsAncestorOf scopeIndex scopeOne scopeThree @?= Right True + scopeLca scopeIndex scopeTwo scopeThree @?= Right scopeTwo, + testCase "preorder-chain construction stays linear before lift-table construction" $ do + let chainSize = 32768 + parentVector = + Vector.generate chainSize (\scopeKey -> max 0 (scopeKey - 1)) + scopeIndex <- + expectRightWithLabel + "deep chain scope index" + (mkScopeIndex parentVector Vector.empty) + deepestScope <- expectRightWithLabel "deepest chain scope" (mkScopeId (chainSize - 1)) + scopeTopCtx scopeIndex @?= Right (ActualScope deepestScope), + testCase "a preorder branch has incompatible top and range-correct ancestry" $ do + scopeIndex <- + expectRightWithLabel + "branch scope index" + (mkScopeIndex (Vector.fromList [0, 0, 1, 0]) Vector.empty) + scopeOne <- expectRightWithLabel "scope one" (mkScopeId 1) + scopeThree <- expectRightWithLabel "scope three" (mkScopeId 3) + scopeTopCtx scopeIndex @?= Right IncompatibleScope + scopeIsAncestorOf scopeIndex scopeOne scopeThree @?= Right False + scopeLca scopeIndex scopeOne scopeThree @?= Right rootScopeId, + testCase "free-scope merge retains distinct scopes at equal depth" $ do + scopeOne <- expectRightWithLabel "scope one" (mkScopeId 1) + scopeTwo <- expectRightWithLabel "scope two" (mkScopeId 2) + let leftSummary = singletonFreeScopeSummary scopeOne + rightSummary = singletonFreeScopeSummary scopeTwo + expectedScopes = [scopeOne, scopeTwo] + freeScopeSummaryToList + (mergeFreeScopeSummaryBy (const 1) leftSummary rightSummary) + @?= expectedScopes + freeScopeSummaryToList + (mergeFreeScopeSummaryBy (const 1) rightSummary leftSummary) + @?= expectedScopes, + testCase "module metrics derive wrapper free scopes from the canonical expression" $ do + convertedModule <- + expectRightWithLabel + "metrics wrapper fixture" + ( convertHaskellSource + "Counterexample.hs" + ( unlines + [ "module Counterexample where", + "f x y = let { g True = x; g False = y } in g True" + ] + ) + ) + let metrics = convertedModuleMetrics convertedModule + cmmMaxFreeScopeCount metrics @?= 2, + testCase "sealed binding metric sections equal checked structural projections" $ do + convertedModule <- + expectRightWithLabel + "metric section fixture" + ( convertHaskellSource + "MetricSections.hs" + ( unlines + [ "module MetricSections where", + "nested x y = let { choose True = x; choose False = y } in choose True", + "guarded value | value = external | otherwise = value", + "multi True value = value", + "multi False _ = external", + "plain = external" + ] + ) + ) + projectedBindings <- + expectRightWithLabel + "checked metric projections" + ( traverse + (bindingExpr (cmScopeIndex convertedModule)) + (convertedModuleBindings convertedModule) + ) + let metrics = convertedModuleMetrics convertedModule + oracleMetrics = + foldMap expressionMetricOracle projectedBindings + ( cmmScopedExprCount metrics, + cmmGlobalVarRefCount metrics, + cmmLocalVarRefCount metrics, + cmmMaxFreeScopeCount metrics + ) + @?= ( oracleScopedExprCount oracleMetrics, + oracleGlobalVarRefCount oracleMetrics, + oracleLocalVarRefCount oracleMetrics, + oracleMaxFreeScopeCount oracleMetrics + ), + testCase "binding dependencies distinguish independent, acyclic, and cyclic groups" $ do + convertedModule <- + expectRightWithLabel + "dependency fixture" + ( convertHaskellSource + "Dependencies.hs" + ( unlines + [ "module Dependencies where", + "independent = let { a = 1; b = 2 } in a + b", + "acyclic = let { a = 1; b = a } in b", + "recursive = let { a = b; b = a } in a", + "nested = let { a = 1; b = let { inner = a } in inner } in b" + ] + ) + ) + foldMap + (letRecursions . tlbTerm) + (convertedModuleBindings convertedModule) + @?= [ NonRecursiveBinds, + AcyclicDependentBinds, + RecursiveBinds, + AcyclicDependentBinds, + NonRecursiveBinds + ], + testCase "binderless dependent rows do not leak their binding-group scope" $ do + convertedModule <- + expectRightWithLabel + "binderless dependency fixture" + ( convertHaskellSource + "BinderlessDependency.hs" + ( unlines + [ "module BinderlessDependency where", + "closed = let { x = 1; _ = x } in 2" + ] + ) + ) + topLevelBinding <- singleBinding convertedModule + projectedBinding <- + expectRightWithLabel + "binderless dependency projection" + (bindingExpr (cmScopeIndex convertedModule) topLevelBinding) + freeScopeSummaryToList (exprFreeScopes projectedBinding) @?= [], + testCase "singleton binding components preserve generic SCC evidence" $ do + assertSingletonBindingComponent + "one independent binder" + ["one x = y where y = x"] + 1 + AcyclicBindingComponent + assertSingletonBindingComponent + "one recursive binder" + ["self = y where y = y"] + 1 + RecursiveBindingComponent + assertSingletonBindingComponent + "multiple recursive pattern binders" + ["pair x = right where (left, right) = (left, x)"] + 2 + RecursiveBindingComponent + assertSingletonBindingComponent + "no pattern binders" + ["wild x = x where _ = x"] + 0 + AcyclicBindingComponent, + testCase "specialized binding components agree with the generic SCC oracle" $ do + traverse_ + assertBindingComponentsMatchGraphOracle + [ ( "independent rows", + ["subject = a + b + c + d where { a = 1; b = 2; (c, d) = (3, 4); _ = 5 }"] + ), + ( "acyclic rows", + ["subject = c where { a = 1; b = a; c = b }"] + ), + ( "cyclic rows", + ["subject = a where { a = b; b = c; c = a }"] + ), + ( "singleton general pattern", + ["subject x = result where (left, right) = (x, left); result = right"] + ) + ] + ] + +caseAlternativeScopeTests :: TestTree +caseAlternativeScopeTests = + testGroup + "pale.case-scopes" + [ testCase "binderless case alternatives receive distinct child scopes" $ do + (convertedModule, caseScope, nilPattern, nilScope, consPattern, consScope) <- + binderlessCaseAlternativeScopes + patBinders nilPattern @?= [] + patBinders consPattern @?= [] + assertBool "binderless alternatives collapsed into one scope" (nilScope /= consScope) + scopeParentId (cmScopeIndex convertedModule) nilScope @?= Right caseScope + scopeParentId (cmScopeIndex convertedModule) consScope @?= Right caseScope, + testCase "scope restriction reaches binderless sibling alternatives independently" $ do + (convertedModule, caseScope, _, nilScope, _, consScope) <- + binderlessCaseAlternativeScopes + let scopeIndex = cmScopeIndex convertedModule + caseContext = ActualScope caseScope + nilContext = ActualScope nilScope + consContext = ActualScope consScope + scopeCtxLeq scopeIndex caseContext nilContext @?= Right True + scopeCtxLeq scopeIndex caseContext consContext @?= Right True + scopeCtxLeq scopeIndex nilContext consContext @?= Right False + scopeCtxLeq scopeIndex consContext nilContext @?= Right False + scopeCtxMeet scopeIndex nilContext consContext @?= Right caseContext + scopeCtxJoin scopeIndex nilContext consContext @?= Right IncompatibleScope + ] + +binderlessCaseAlternativeScopes :: IO (ConvertedModule, ScopeId, HsPatF, ScopeId, HsPatF, ScopeId) +binderlessCaseAlternativeScopes = do + convertedModule <- + expectRightWithLabel + "binderless case fixture conversion" + ( convertHaskellSource + "BinderlessCase.hs" + ( unlines + [ "module BinderlessCase where", + "", + "classify values = case values of { [] -> empty; (_ : _) -> nonempty }" + ] + ) + ) + bindingValue <- singleBinding convertedModule + case tlbBinding bindingValue of + FunctionBinding _ (Clause _ (UnguardedRhs bodyExpr _) :| []) -> + case exprNode bodyExpr of + CaseF _ [(nilPattern, nilExpr), (consPattern, consExpr)] -> + pure + ( convertedModule, + exprScope bodyExpr, + nilPattern, + exprScope nilExpr, + consPattern, + exprScope consExpr + ) + otherNode -> + assertFailure ("expected a two-alternative scoped case expression, got " <> show otherNode) + otherBinding -> + assertFailure ("expected one-clause function binding around the case expression, got " <> show otherBinding) + +scopeParentVectorCandidates :: [Vector.Vector Int] +scopeParentVectorCandidates = + [ Vector.fromList (0 : parentKeys) + | scopeCount <- [1 .. 8], + parentKeys <- + sequence + [ [0 .. scopeKey - 1] + | scopeKey <- [1 .. scopeCount - 1] + ] + ] + +scopeParentVectorPartition :: + ( [(Vector.Vector Int, ScopeIndexFailure)], + [(Vector.Vector Int, ScopeIndex)] + ) +scopeParentVectorPartition = + partitionEithers + ( fmap + ( \parentVector -> + case mkScopeIndex parentVector Vector.empty of + Left failure -> + Left (parentVector, failure) + Right scopeIndex -> + Right (parentVector, scopeIndex) + ) + scopeParentVectorCandidates + ) + +verifyScopeIndexAgainstParentWalk :: + Vector.Vector Int -> + ScopeIndex -> + Either String () +verifyScopeIndexAgainstParentWalk parentVector scopeIndex = do + let scopeKeys = [0 .. Vector.length parentVector - 1] + scopePairs = (,) <$> scopeKeys <*> scopeKeys + scopeIds <- traverse checkedScopeId scopeKeys + traverse_ (verifyScopePair parentVector scopeIndex) scopePairs + pairComparabilities <- + traverse + ( \(leftKey, rightKey) -> + (||) + <$> parentWalkIsAncestor parentVector leftKey rightKey + <*> parentWalkIsAncestor parentVector rightKey leftKey + ) + scopePairs + scopeDepths <- + traverse + ( \scopeKey -> + fmap + (\ancestors -> (scopeKey, length ancestors - 1)) + (parentWalkAncestors parentVector scopeKey) + ) + scopeKeys + let hasIncomparableScopes = any not pairComparabilities + (deepestScopeKey, _deepestDepth) = + foldl' preferDeeperScope (0, 0) scopeDepths + deepestScope <- checkedScopeId deepestScopeKey + let expectedTopContext = + if hasIncomparableScopes + then IncompatibleScope + else ActualScope deepestScope + expectedObservedContexts = + fmap ActualScope scopeIds + <> [IncompatibleScope | hasIncomparableScopes] + requireEqual + "scope top-context classification" + (Right expectedTopContext) + (scopeTopCtx scopeIndex) + requireEqual + "scope observed-context branch classification" + (Right expectedObservedContexts) + (scopeObservedContexts scopeIndex) + where + preferDeeperScope :: (Int, Int) -> (Int, Int) -> (Int, Int) + preferDeeperScope deepest@(_deepestKey, deepestDepth) candidate@(_candidateKey, candidateDepth) + | candidateDepth > deepestDepth = + candidate + | otherwise = + deepest + +verifyScopePair :: + Vector.Vector Int -> + ScopeIndex -> + (Int, Int) -> + Either String () +verifyScopePair parentVector scopeIndex (leftKey, rightKey) = do + leftScope <- checkedScopeId leftKey + rightScope <- checkedScopeId rightKey + expectedLeftAncestor <- + parentWalkIsAncestor parentVector leftKey rightKey + expectedRightAncestor <- + parentWalkIsAncestor parentVector rightKey leftKey + requireEqual + ("scopeIsAncestorOf " <> show (leftKey, rightKey)) + (Right expectedLeftAncestor) + (scopeIsAncestorOf scopeIndex leftScope rightScope) + requireEqual + ("scopeComparable " <> show (leftKey, rightKey)) + (Right (expectedLeftAncestor || expectedRightAncestor)) + (scopeComparable scopeIndex leftScope rightScope) + +checkedScopeId :: Int -> Either String ScopeId +checkedScopeId scopeKey = + case mkScopeId scopeKey of + Left failure -> + Left ("scope-id construction failed: " <> show failure) + Right scopeId -> + Right scopeId + +parentWalkIsAncestor :: + Vector.Vector Int -> + Int -> + Int -> + Either String Bool +parentWalkIsAncestor parentVector candidateAncestor scopeKey = + elem candidateAncestor + <$> parentWalkAncestors parentVector scopeKey + +parentWalkAncestors :: + Vector.Vector Int -> + Int -> + Either String [Int] +parentWalkAncestors parentVector = + descend (Vector.length parentVector + 1) + where + descend remainingSteps scopeKey + | remainingSteps <= 0 = + Left ("parent walk did not reach the root from scope " <> show scopeKey) + | scopeKey == 0 = + Right [0] + | otherwise = + case parentVector Vector.!? scopeKey of + Nothing -> + Left + ( "parent walk left the vector at scope " + <> show scopeKey + <> " of " + <> show (Vector.length parentVector) + ) + Just parentKey + | parentKey < 0 || parentKey >= scopeKey -> + Left + ( "parent walk encountered invalid edge " + <> show (scopeKey, parentKey) + ) + | otherwise -> + (scopeKey :) + <$> descend (remainingSteps - 1) parentKey + +requireEqual :: + (Eq value, Show value) => + String -> + value -> + value -> + Either String () +requireEqual label expected actual + | expected == actual = + Right () + | otherwise = + Left + ( label + <> "\nexpected: " + <> show expected + <> "\nactual: " + <> show actual + ) + +renderRoundTripTests :: TestTree +renderRoundTripTests = + testGroup + "render.roundtrip" + [ roundTripCase + "lambda and application round-trip" + [ "module Fixture where", + "", + "handle = \\evt -> process evt evt" + ], + testCase "SCC expression pragmas transparently convert their wrapped expression" $ do + let wrappedSource = + unlines + [ "module SccWrappedExpression where", + "instrumented value = {-# SCC \"nebula.ingest.parse\" #-} value + 1" + ] + plainSource = + unlines + [ "module SccWrappedExpression where", + "instrumented value = value + 1" + ] + wrappedModule <- + expectRightWithLabel + "SCC-wrapped expression conversion" + (convertHaskellSource "SccWrappedExpression.hs" wrappedSource) + plainModule <- + expectRightWithLabel + "plain expression conversion" + (convertHaskellSource "SccWrappedExpression.hs" plainSource) + wrappedBinding <- singleBinding wrappedModule + plainBinding <- singleBinding plainModule + assertBool + "SCC wrapper changed the converted expression" + (renderRoundTripEquivalent (tlbTerm wrappedBinding) (tlbTerm plainBinding)), + roundTripCase + "multi-argument function becomes a lambda chain" + [ "module Fixture where", + "", + "apply2 f x = f x x" + ], + roundTripCase + "plain where round-trips with layout" + [ "module Fixture where", + "", + "scale x = base * x", + " where", + " base = 10" + ], + roundTripCase + "multi-bind where round-trips" + [ "module Fixture where", + "", + "f x = combine y z", + " where", + " y = deriveY x", + " z = deriveZ x" + ], + roundTripCase + "where guarded local function round-trips" + [ "module Fixture where", + "", + "clamp q = saturate q", + " where", + " saturate value", + " | value > upper = upper", + " | value < lower = lower", + " | otherwise = value" + ], + roundTripCase + "where tuple pattern bind round-trips" + [ "module Fixture where", + "", + "f x = combine a b where (a, b) = splitPair x" + ], + roundTripCase + "let constructor pattern bind round-trips" + [ "module Fixture where", + "", + "g m = let Just y = m in use y" + ], + roundTripCase + "mixed var and pattern where binds round-trip" + [ "module Fixture where", + "", + "mix x = combine seed a b", + " where", + " seed = deriveSeed x", + " (a, b) = splitPair x" + ], + roundTripCase + "do-let tuple pattern bind round-trips" + [ "module Fixture where", + "", + "run pair = do { let { (a, b) = pair }; pure (combine a b) }" + ], + roundTripCase + "lazy where pattern bind round-trips" + [ "module Fixture where", + "", + "lazyBind pair = combine a b", + " where", + " ~(a, b) = pair" + ], + roundTripCase + "case with tuple and wildcard branches" + [ "module Fixture where", + "", + "swap p = case p of { (a, b) -> (b, a); _ -> p }" + ], + roundTripCase + "do block with bind, let, and body statements" + [ "module Fixture where", + "", + "run action = do { x <- action; let { y = combine x x }; pure y }" + ], + testCase "generated top-level binding renders do and let as layout while compact rendering stays compact" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "run action = do { x <- action; let { y = combine x x }; pure y }" + ] + ) + ) + bindingValue <- singleBinding convertedModule + compactRendered <- + expectRightWithLabel + "compact render" + (renderSourceString CompactLayout (RenderSourceBinding (tlbBinding bindingValue))) + assertBool + ("compact top-level renderer changed its round-trip surface:\n" <> compactRendered) + ("do {" `isInfixOf` compactRendered && "let {" `isInfixOf` compactRendered) + generatedRendered <- + expectRightWithLabel + "generated render" + ( renderSourceString + (PrettyLayout defaultPageWidth) + (RenderSourceBinding (tlbBinding bindingValue)) + ) + assertBool + ("generated renderer still emitted compact do syntax:\n" <> generatedRendered) + (not ("do {" `isInfixOf` generatedRendered)) + assertBool + ("generated renderer still emitted compact let syntax:\n" <> generatedRendered) + (not ("let {" `isInfixOf` generatedRendered)) + assertBool + ("generated renderer did not emit layout do syntax:\n" <> generatedRendered) + ("\n do" `isInfixOf` generatedRendered || "= do" `isInfixOf` generatedRendered) + reparsedModule <- + expectRightWithLabel + "re-parse of generated rendering" + (convertHaskellSource "Generated.hs" ("module Generated where\n\n" <> generatedRendered <> "\n")) + reparsedBinding <- singleBinding reparsedModule + assertRoundTripBinding generatedRendered (bindingValue, reparsedBinding), + testCase "readable rendering keeps lambda-case out of brace layout" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "choose input = consume (\\case { Just x -> pure x; Nothing -> empty }) input" + ] + ) + ) + bindingValue <- singleBinding convertedModule + compactRendered <- + expectRightWithLabel + "compact render" + (renderSourceString CompactLayout (RenderSourceBinding (tlbBinding bindingValue))) + assertBool + ("compact lambda-case renderer changed its round-trip surface:\n" <> compactRendered) + ("\\case {" `isInfixOf` compactRendered) + readableRendered <- + expectRightWithLabel + "readable render" + ( renderSourceString + (PrettyLayout defaultPageWidth) + (RenderSourceBinding (tlbBinding bindingValue)) + ) + assertBool + ("readable renderer still emitted compact lambda-case syntax:\n" <> readableRendered) + (not ("\\case {" `isInfixOf` readableRendered)) + assertBool + ("readable renderer did not emit layout lambda-case syntax:\n" <> readableRendered) + ("\\case\n" `isInfixOf` readableRendered) + reparsedModule <- + expectRightWithLabel + "re-parse of readable rendering" + (convertHaskellSource "Readable.hs" ("module Readable where\n\n" <> readableRendered <> "\n")) + reparsedBinding <- singleBinding reparsedModule + assertRoundTripBinding readableRendered (bindingValue, reparsedBinding), + testCase "readable rendering keeps record construction in layout form" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "record = Metrics { alpha = one, beta = two }" + ] + ) + ) + bindingValue <- singleBinding convertedModule + compactRendered <- + expectRightWithLabel + "compact render" + (renderSourceString CompactLayout (RenderSourceBinding (tlbBinding bindingValue))) + assertBool + ("compact record renderer changed its round-trip surface:\n" <> compactRendered) + ("{ alpha = one, beta = two }" `isInfixOf` compactRendered) + readableRendered <- + expectRightWithLabel + "readable render" + ( renderSourceString + (PrettyLayout defaultPageWidth) + (RenderSourceBinding (tlbBinding bindingValue)) + ) + assertBool + ("readable renderer still emitted one-line record syntax:\n" <> readableRendered) + (not ("{ alpha = one, beta = two }" `isInfixOf` readableRendered)) + assertBool + ("readable renderer did not emit layout record syntax:\n" <> readableRendered) + ("\n { alpha = one\n , beta = two\n }" `isInfixOf` readableRendered) + reparsedModule <- + expectRightWithLabel + "re-parse of readable record rendering" + (convertHaskellSource "ReadableRecord.hs" ("module ReadableRecord where\n\n" <> readableRendered <> "\n")) + reparsedBinding <- singleBinding reparsedModule + assertRoundTripBinding readableRendered (bindingValue, reparsedBinding), + roundTripCase + "operator applications with symbolic and alphanumeric operators" + [ "module Fixture where", + "", + "total a b c = a + b * c", + "", + "halve a b = a `div` b", + "", + "summed = foldr (+) 0" + ], + testCase "mixed-precedence operator chains render without parser-tree parens" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "bounded value = value >= 0 && value <= 32" + ] + ) + ) + renderedSource <- + expectRightWithLabel + "render" + (renderFixtureModule "Fixture" convertedModule) + assertBool + ("mixed fixity chain was rendered through the parser tree:\n" <> renderedSource) + (not ("((value >= 0) && value) <= 32" `isInfixOf` renderedSource)) + assertBool + ("mixed fixity chain lost its surface order:\n" <> renderedSource) + ("value >= 0 && value <= 32" `isInfixOf` renderedSource), + testCase "custom fixity declarations and surface-order chains survive module rendering" $ do + convertedModule <- + expectRightWithLabel + "custom-fixity conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "infixr 4 <~>", + "infixl 6 <+>", + "chain = a <~> b <+> c <~> d" + ] + ) + ) + renderedSource <- + expectRightWithLabel + "custom-fixity module rendering" + (renderFixtureModule "Fixture" convertedModule) + assertBool "right-associative fixity declaration was lost" ("infixr 4 <~>" `isInfixOf` renderedSource) + assertBool "left-associative fixity declaration was lost" ("infixl 6 <+>" `isInfixOf` renderedSource) + assertBool "operator chain surface order was lost" ("a <~> b <+> c <~> d" `isInfixOf` renderedSource) + reparsedModule <- + expectRightWithLabel + "custom-fixity rendered-source conversion" + (convertHaskellSource "Fixture.hs" renderedSource) + originalBinding <- singleBinding convertedModule + reparsedBinding <- singleBinding reparsedModule + assertRoundTripBinding renderedSource (originalBinding, reparsedBinding), + testCase "alpha equivalence follows binder identity under shadowing" $ do + let leftOuter = BinderAnn (BinderId 0) (mkRdrUnqual (mkVarOcc "x")) + leftInner = BinderAnn (BinderId 1) (mkRdrUnqual (mkVarOcc "x")) + rightOuter = BinderAnn (BinderId 10) (mkRdrUnqual (mkVarOcc "a")) + rightInner = BinderAnn (BinderId 11) (mkRdrUnqual (mkVarOcc "b")) + leftTerm = + PatternNode + (LamF leftOuter (PatternNode (LamF leftInner (PatternNode (VarF (LocalName leftOuter)))))) + alphaRenamed = + PatternNode + (LamF rightOuter (PatternNode (LamF rightInner (PatternNode (VarF (LocalName rightOuter)))))) + captured = + PatternNode + (LamF rightOuter (PatternNode (LamF rightInner (PatternNode (VarF (LocalName rightInner)))))) + assertBool "alpha-renamed outer reference should remain equivalent" (renderRoundTripEquivalent leftTerm alphaRenamed) + assertBool "outer and inner shadowed references must not collapse" (not (renderRoundTripEquivalent leftTerm captured)), + testCase "capture-avoiding rendering freshens binders against globals" $ do + let binderAnn = BinderAnn (BinderId 0) (mkRdrUnqual (mkVarOcc "x")) + globalName = mkRdrUnqual (mkVarOcc "x") + term = + PatternNode + ( LamF + binderAnn + (PatternNode (AppF (PatternNode (VarF (GlobalName globalName))) (PatternNode (VarF (LocalName binderAnn))))) + ) + renderSourceString CompactLayout (RenderRewriteExpression term) + @?= Right "\\x_0 -> x x_0", + testCase "repeated binder spellings use one flat suffix frontier" $ do + let outerBinder = BinderAnn (BinderId 0) (mkRdrUnqual (mkVarOcc "value")) + middleBinder = BinderAnn (BinderId 1) (mkRdrUnqual (mkVarOcc "value")) + innerBinder = BinderAnn (BinderId 2) (mkRdrUnqual (mkVarOcc "value")) + term = + PatternNode + ( LamF + outerBinder + ( PatternNode + ( LamF + middleBinder + ( PatternNode + ( LamF + innerBinder + (PatternNode (VarF (LocalName innerBinder))) + ) + ) + ) + ) + ) + renderSourceString CompactLayout (RenderRewriteExpression term) + @?= Right "\\value -> \\value_0 -> \\value_1 -> value_1", + testCase "tuple sections preserve missing slots and boxity" $ do + boxedModule <- + expectRightWithLabel + "boxed tuple-section conversion" + (convertHaskellSource "Boxed.hs" (unlines ["{-# LANGUAGE TupleSections #-}", "module Boxed where", "section x = (, x)"])) + unboxedModule <- + expectRightWithLabel + "unboxed tuple-section conversion" + ( convertHaskellSource + "Unboxed.hs" + (unlines ["{-# LANGUAGE MagicHash #-}", "{-# LANGUAGE TupleSections #-}", "{-# LANGUAGE UnboxedTuples #-}", "module Unboxed where", "section x = (# x, #)"]) + ) + boxedBinding <- singleBinding boxedModule + unboxedBinding <- singleBinding unboxedModule + case stripBindingLambdas (tlbTerm boxedBinding) of + PatternNode (ExplicitTupleF BoxedTuple [TupleMissing, TuplePresent _]) -> pure () + otherTerm -> assertFailure ("unexpected boxed tuple-section structure: " <> show otherTerm) + case stripBindingLambdas (tlbTerm unboxedBinding) of + PatternNode (ExplicitTupleF UnboxedTuple [TuplePresent _, TupleMissing]) -> pure () + otherTerm -> assertFailure ("unexpected unboxed tuple-section structure: " <> show otherTerm), + testCase "top-level pattern bindings are represented rather than omitted" $ do + convertedModule <- + expectRightWithLabel + "top-level pattern conversion" + (convertHaskellSource "PatternBinding.hs" (unlines ["module PatternBinding where", "Just value = source"])) + bindingValue <- singleBinding convertedModule + case tlbBinding bindingValue of + PatternBinding (PConP _ [PVarP _]) _ -> pure () + otherBinding -> assertFailure ("unexpected top-level binding structure: " <> show otherBinding), + testCase "case operand in operator application uses byte-stable compact braces" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "globalReferenceNames nodeValue = (case nodeValue of { Just value -> pure value; Nothing -> mempty }) <> foldMap globalReferenceNames nodeValue" + ] + ) + ) + bindingValue <- singleBinding convertedModule + renderedSource <- + expectRightWithLabel + "render" + (renderFixtureModule "Fixture" convertedModule) + assertBool + ("case expression did not use compact brace layout:\n" <> renderedSource) + ("case nodeValue of { Just value -> pure value; Nothing -> mempty }" `isInfixOf` renderedSource) + reparsedModule <- expectRightWithLabel "re-parse of rendered source" (convertHaskellSource "Fixture.hs" renderedSource) + reparsedBinding <- singleBinding reparsedModule + assertRoundTripBinding renderedSource (bindingValue, reparsedBinding), + roundTripCase + "left and right sections" + [ "module Fixture where", + "", + "increment = (1 +)", + "", + "halved = (`div` 2)" + ], + roundTripCase + "if-then-else" + [ "module Fixture where", + "", + "choose c = if c then trueBranch else falseBranch" + ], + roundTripCase + "multi-way if with boolean guards round-trips" + [ "module Fixture where", + "", + "choose x = if | isSmall x -> small", + " | isBig x -> big", + " | otherwise -> unknown" + ], + roundTripCase + "multi-way if with pattern guard round-trips" + [ "module Fixture where", + "", + "pick source = if | Just y <- lookupThing source -> y", + " | otherwise -> fallback" + ], + roundTripCase + "expression type signature in argument position round-trips" + [ "module Fixture where", + "", + "typedArg x = apply (x :: Int)" + ], + roundTripCase + "type applications round-trip" + [ "module Fixture where", + "", + "typedApps f = pair (f @Int) (f @(Maybe a))" + ], + roundTripCase + "lists and tuples" + [ "module Fixture where", + "", + "trio = [1, 2, 3]", + "", + "pair = (1, \"two\")" + ], + roundTripCase + "record construction" + [ "module Fixture where", + "", + "settings = MkSettings { width = 3, label = \"wide\" }" + ], + roundTripCase + "record update" + [ "module Fixture where", + "", + "widen settings = settings { width = 4, label = \"wider\" }" + ], + roundTripCase + "record patterns round-trip" + [ "module Fixture where", + "", + "recordPat value = case value of { MkRec {left = Just a, right = (b, c)} -> combine a b c; EmptyRec {} -> empty; _ -> fallback }" + ], + roundTripCase + "record pun pattern round-trips" + [ "module Fixture where", + "", + "recordPun value = case value of { MkRec {field} -> field; _ -> fallback }" + ], + roundTripCase + "arithmetic sequences" + [ "module Fixture where", + "", + "open = [0 ..]", + "", + "steppedOpen = [0, 2 ..]", + "", + "closed = [0 .. 10]", + "", + "steppedClosed = [0, 2 .. 10]" + ], + roundTripCase + "negation" + [ "module Fixture where", + "", + "invert x = -x" + ], + roundTripCase + "character, string, and numeric literals" + [ "module Fixture where", + "", + "letter = 'c'", + "", + "greeting = \"hello\"", + "", + "answer = 42", + "", + "ratio = 2.5" + ], + roundTripCase + "symbolic top-level definition" + [ "module Fixture where", + "", + "(<+>) = \\x -> x" + ], + roundTripCase + "nested let and shadow-style reuse" + [ "module Fixture where", + "", + "shadow = let g = \\x -> use x x in g alpha" + ], + roundTripCase + "constructor-pattern case alternatives round-trip" + [ "module Fixture where", + "", + "unwrap m = case m of { Just x -> x; Nothing -> fallback }" + ], + roundTripCase + "nested constructor patterns round-trip" + [ "module Fixture where", + "", + "nested x = case x of { Just (Left y) -> y; _ -> other }" + ], + roundTripCase + "as-patterns round-trip" + [ "module Fixture where", + "", + "asPat x = case x of { all@(Just y) -> use all y; Nothing -> base }" + ], + roundTripCase + "list patterns round-trip" + [ "module Fixture where", + "", + "listPat xs = case xs of { [a, b] -> combine a b; _ -> empty }" + ], + roundTripCase + "tuple-inside-constructor patterns round-trip" + [ "module Fixture where", + "", + "tupCon x = case x of { Just (a, b) -> pair a b; Nothing -> base }" + ], + roundTripCase + "integer literal alternatives round-trip" + [ "module Fixture where", + "", + "classify n = case n of { 0 -> zero; _ -> other }" + ], + roundTripCase + "character and string literal alternatives round-trip" + [ "module Fixture where", + "", + "tag c = case c of { 'a' -> alpha; 'b' -> beta; _ -> other }", + "", + "named s = case s of { \"yes\" -> true; _ -> false }" + ], + roundTripCase + "infix constructor patterns round-trip" + [ "module Fixture where", + "", + "headTail xs = case xs of { (h : t) -> use h t; [] -> base }" + ], + roundTripCase + "bang patterns in case alternatives round-trip" + [ "module Fixture where", + "", + "strict x = case x of { !y -> use y }" + ], + roundTripCase + "wildcard alternatives round-trip" + [ "module Fixture where", + "", + "ignore x = case x of { _ -> constant }" + ], + roundTripCase + "do-bind with constructor pattern round-trips" + [ "module Fixture where", + "", + "run action = do { Just v <- action; pure v }" + ], + roundTripCase + "adversarial tuple-of-constructor-and-list pattern round-trips" + [ "module Fixture where", + "", + "adversarial x = case x of { (Just a, [b, c]) -> combine a b c; _ -> base }" + ], + roundTripCase + "guarded otherwise chain round-trips" + [ "module Fixture where", + "", + "choose x", + " | isPrimary x = primary", + " | otherwise = secondary" + ], + roundTripCase + "multi-alternative boolean guard chain round-trips" + [ "module Fixture where", + "", + "traffic signal", + " | isRed signal = stop", + " | isYellow signal = caution", + " | isGreen signal = go", + " | otherwise = unknown" + ], + roundTripCase + "pattern guard round-trips" + [ "module Fixture where", + "", + "lookupValue x", + " | Just y <- lookupThing x = y", + " | otherwise = fallback" + ], + roundTripCase + "let guard round-trips" + [ "module Fixture where", + "", + "letGuard x", + " | let { y = normalize x } = y" + ], + roundTripCase + "guarded case alternative round-trips" + [ "module Fixture where", + "", + "select m = case m of { Just x | valid x -> x; _ -> fallback }" + ], + roundTripCase + "case alternative where round-trips" + [ "module Fixture where", + "", + "select m = case m of { Just x -> use x y where { y = derive x }; Nothing -> fallback }" + ], + roundTripCase + "guarded binding with multiple arguments round-trips" + [ "module Fixture where", + "", + "combineGuard a b", + " | ok a b = pair a b", + " | otherwise = fallback a b" + ], + roundTripCase + "guarded where round-trips" + [ "module Fixture where", + "", + "f x", + " | isBig x = large y", + " | otherwise = small y", + " where", + " y = derive x" + ], + roundTripCase + "clauses multi-clause recursion round-trips" + [ "module Fixture where", + "", + "factorial 0 = 1", + "factorial n = times n (factorial (minus n one))" + ], + roundTripCase + "clauses multi-clause constructor patterns round-trip" + [ "module Fixture where", + "", + "unwrap (Just x) = x", + "unwrap Nothing = fallback" + ], + roundTripCase + "clauses pattern lambda in expression position round-trips" + [ "module Fixture where", + "", + "mapper = apply (\\(Just x) -> use x)" + ], + roundTripCase + "clauses lambda-case multi-alternative round-trips" + [ "module Fixture where", + "", + "handler = \\case { Just x -> use x; Nothing -> fallback }" + ], + roundTripCase + "clauses lambda-cases two-pattern round-trips" + [ "module Fixture where", + "", + "combiner = \\cases { (Just x) (Just y) -> pair x y; _ _ -> fallback }" + ], + roundTripCase + "clauses guarded multi-clause binding round-trips" + [ "module Fixture where", + "", + "classify x", + " | isBig x = large", + "classify y = small y" + ], + roundTripCase + "clause where under multi-clause definition round-trips" + [ "module Fixture where", + "", + "choose 0 = zero", + "choose n = combine n y", + " where", + " y = derive n" + ], + testCase "clauses multi-clause definition converts without opaque lambda match group" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "factorial 0 = 1", + "factorial n = times n (factorial (minus n one))" + ] + ) + ) + bindingValue <- singleBinding convertedModule + case tlbTerm bindingValue of + PatternNode (ClausesF clauseValues) -> do + length clauseValues @?= 2 + case fmap fst clauseValues of + [[POverLitP (NormalizedIntegralOverLit zeroValue)], [PVarP _]] + | exactIntegralValue zeroValue == 0 -> + pure () + patternShapes -> + assertFailure ("expected literal and variable clause patterns, got " <> show patternShapes) + otherTerm -> + assertFailure ("expected a ClausesF multi-clause binding, got " <> show otherTerm), + testCase "clauses var-only single-clause top-level rendering refuses lam territory" $ do + let binderAnn = BinderAnn (BinderId 0) (mkRdrUnqual (mkVarOcc "x")) + bodyValue :: Pattern HsExprF + bodyValue = PatternNode (VarF (LocalName binderAnn)) + renderSourceString + CompactLayout + ( RenderNamedRewriteBinding + "identity" + (PatternNode (ClausesF [([PVarP binderAnn], bodyValue)])) + ) + @?= Left RenderClausesShape, + testCase "expression lambda remains on the rhs and reconverts" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "f = \\x -> use x" + ] + ) + ) + bindingValue <- singleBinding convertedModule + renderedSource <- + expectRightWithLabel + "render" + (renderFixtureModule "Fixture" convertedModule) + renderedSource @?= unlines ["module Fixture where", "", "f = \\x -> use x"] + reparsedModule <- expectRightWithLabel "re-parse of rendered source" (convertHaskellSource "Fixture.hs" renderedSource) + reparsedBinding <- singleBinding reparsedModule + assertRoundTripBinding renderedSource (bindingValue, reparsedBinding), + testCase "guarded where renders compactly and reconverts" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "f x | isBig x = large y | otherwise = small y where y = derive x" + ] + ) + ) + bindingValue <- singleBinding convertedModule + renderedSource <- + expectRightWithLabel + "render" + (renderFixtureModule "Fixture" convertedModule) + renderedSource + @?= unlines + [ "module Fixture where", + "", + "f x | isBig x = large y | otherwise = small y where { y = derive x }" + ] + reparsedModule <- expectRightWithLabel "re-parse of rendered source" (convertHaskellSource "Fixture.hs" renderedSource) + reparsedBinding <- singleBinding reparsedModule + assertRoundTripBinding renderedSource (bindingValue, reparsedBinding), + testCase "guarded binding converts without opaque fallback" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "lookupValue x", + " | Just y <- lookupThing x = y" + ] + ) + ) + bindingValue <- singleBinding convertedModule + case stripBindingLambdas (tlbTerm bindingValue) of + PatternNode (GuardedF [GuardedAltF [GuardPatF (PConP _ [PVarP guardBinder]) _] (PatternNode (VarF (LocalName bodyBinder)))]) -> + occNameString (rdrNameOcc (baName guardBinder)) @?= occNameString (rdrNameOcc (baName bodyBinder)) + otherBody -> + assertFailure ("expected a pattern-guarded body, got " <> show otherBody), + testCase "multi-way if pattern guard converts without opaque fallback" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "pick source = if | Just y <- lookupThing source -> y", + " | otherwise -> fallback" + ] + ) + ) + bindingValue <- singleBinding convertedModule + case stripBindingLambdas (tlbTerm bindingValue) of + PatternNode (MultiIfF [GuardedAltF [GuardPatF (PConP _ [PVarP guardBinder]) _] (PatternNode (VarF (LocalName bodyBinder))), GuardedAltF [GuardBoolF _] _]) -> + occNameString (rdrNameOcc (baName guardBinder)) @?= occNameString (rdrNameOcc (baName bodyBinder)) + otherBody -> + assertFailure ("expected a pattern-guarded multi-way if, got " <> show otherBody), + testCase "type syntax constructors convert without opaque fallback" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "typed f x = pair (apply (x :: Int)) (pair (f @Int) (f @(Maybe a)))" + ] + ) + ) + bindingValue <- singleBinding convertedModule + assertBool + "fixture must contain an expression type signature node" + (patternContainsExprWithTySig (tlbTerm bindingValue)) + assertBool + "fixture must contain visible type application nodes" + (patternContainsAppType (tlbTerm bindingValue)), + testCase "record patterns convert to field rows without lossy fallback" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "recordPat value = case value of { MkRec {left = Just a, right = (b, c)} -> combine a b c; EmptyRec {} -> empty; _ -> fallback }" + ] + ) + ) + bindingValue <- singleBinding convertedModule + case stripBindingLambdas (tlbTerm bindingValue) of + PatternNode (CaseF _ branchValues) -> + case fmap (stripTestPatParens . fst) branchValues of + [ PRecP _ + [ HsRecPatField leftName (HsRecPatExplicit (PConP _ [PVarP _])), + HsRecPatField rightName (HsRecPatExplicit (PTupleP BoxedTuple [PVarP _, PVarP _])) + ], + PRecP _ [], + PWildP + ] -> do + fmap (occNameString . rdrNameOcc) [leftName, rightName] + @?= ["left", "right"] + alternativePatterns -> + assertFailure ("expected faithful record pattern rows, got " <> show alternativePatterns) + otherBody -> + assertFailure ("expected a case expression with record patterns, got " <> show otherBody), + testCase "record pun syntax and binder identity are preserved" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "recordPun value = case value of { MkRec {field} -> field; _ -> fallback }" + ] + ) + ) + bindingValue <- singleBinding convertedModule + case stripBindingLambdas (tlbTerm bindingValue) of + PatternNode + ( CaseF + _ + [ (PRecP _ [HsRecPatField fieldName (HsRecPatPun punBinder)], PatternNode (VarF (LocalName bodyBinder))), + (PWildP, _) + ] + ) -> do + occNameString (rdrNameOcc fieldName) @?= "field" + baId punBinder @?= baId bodyBinder + bodyPattern -> + assertFailure + ("expected a preserved record pun and local body reference, got " <> show bodyPattern) + renderedSource <- + expectRightWithLabel + "render" + (renderFixtureModule "Fixture" convertedModule) + assertBool + ("record pun must remain pun syntax:\n" <> renderedSource) + ( "MkRec {field}" `isInfixOf` renderedSource + && not ("field = field" `isInfixOf` renderedSource) + && "{-# LANGUAGE NamedFieldPuns #-}" `isInfixOf` renderedSource + ) + reparsedModule <- expectRightWithLabel "re-parse of rendered source" (convertHaskellSource "Fixture.hs" renderedSource) + reparsedBinding <- singleBinding reparsedModule + assertRoundTripBinding renderedSource (bindingValue, reparsedBinding), + testCase "record wildcard patterns require region-bearing field evidence" $ + case + convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "recordWildcard value = case value of { MkRec {..} -> fallback }" + ] + ) + of + Left + ( ConvertRecordWildcardResolutionUnavailable + wildcardRegion + (RecordWildcardConstructorUnavailable constructorName) + ) -> do + srStartLine wildcardRegion @?= 3 + occNameString (rdrNameOcc constructorName) @?= "MkRec" + Left obstruction -> + assertFailure + ("expected missing record-wildcard field evidence, got " <> show obstruction) + Right _ -> + assertFailure "expected missing record-wildcard field evidence, got successful conversion", + testCase "resolved wildcard-only patterns mint real local binders in definition order" $ do + let recordEnvironment = + recordFieldEnvironmentFromStrings + [("MkRec", ["left", "right"])] + sourceText = + unlines + [ "{-# LANGUAGE RecordWildCards #-}", + "module WildcardOnly where", + "recordWildcard value = case value of { MkRec {..} -> combine left right }" + ] + convertedModule <- + expectRightWithLabel + "resolved wildcard-only conversion" + ( convertHaskellSourceWithRecordFieldEnvironment + recordEnvironment + "WildcardOnly.hs" + sourceText + ) + bindingValue <- singleBinding convertedModule + case stripBindingLambdas (tlbTerm bindingValue) of + PatternNode + ( CaseF + _ + [(recordPattern@(PRecP _ [HsRecPatWildcard wildcardRegion wildcardBinders]), branchBody)] + ) -> do + srStartLine wildcardRegion @?= 3 + fmap (occNameString . rdrNameOcc . baName) wildcardBinders + @?= ["left", "right"] + fmap (occNameString . rdrNameOcc . baName) (patBinders recordPattern) + @?= ["left", "right"] + Set.fromList (patternLocalReferences branchBody) + @?= Set.fromList (fmap baId wildcardBinders) + Set.intersection + (Set.fromList ["left", "right"]) + (Set.fromList (patternGlobalReferenceNames branchBody)) + @?= Set.empty + bodyPattern -> + assertFailure + ("expected a wildcard-only record pattern, got " <> show bodyPattern), + testCase "mixed explicit, pun, and wildcard items preserve order, binders, headers, and round-trip syntax" $ do + let recordEnvironment = + recordFieldEnvironmentFromStrings + [("MkRec", ["explicit", "pun", "implicit", "later"])] + sourceText = + unlines + [ "{-# LANGUAGE NamedFieldPuns #-}", + "{-# LANGUAGE RecordWildCards #-}", + "{-# LANGUAGE MultiWayIf #-}", + "module MixedRecordWildcard where", + "record value = case value of { MkRec {explicit = renamed, pun, ..} -> if | condition -> combine renamed pun implicit later }" + ] + convertedModule <- + expectRightWithLabel + "mixed record-wildcard conversion" + ( convertHaskellSourceWithRecordFieldEnvironment + recordEnvironment + "MixedRecordWildcard.hs" + sourceText + ) + bindingValue <- singleBinding convertedModule + case stripBindingLambdas (tlbTerm bindingValue) of + PatternNode + ( CaseF + _ + [ ( recordPattern@(PRecP + _ + [ HsRecPatField explicitName (HsRecPatExplicit (PVarP explicitBinder)), + HsRecPatField punName (HsRecPatPun punBinder), + HsRecPatWildcard wildcardRegion wildcardBinders + ] + ), + branchBody + ) + ] + ) -> do + fmap (occNameString . rdrNameOcc) [explicitName, punName] + @?= ["explicit", "pun"] + srStartLine wildcardRegion @?= 5 + fmap (occNameString . rdrNameOcc . baName) wildcardBinders + @?= ["implicit", "later"] + fmap (occNameString . rdrNameOcc . baName) (patBinders recordPattern) + @?= ["renamed", "pun", "implicit", "later"] + Set.fromList (patternLocalReferences branchBody) + @?= Set.fromList + (fmap baId (explicitBinder : punBinder : wildcardBinders)) + Set.intersection + (Set.fromList ["renamed", "pun", "implicit", "later"]) + (Set.fromList (patternGlobalReferenceNames branchBody)) + @?= Set.empty + bodyPattern -> + assertFailure + ("expected ordered mixed record items, got " <> show bodyPattern) + assertSpannedBindingLockstep (cmScopeIndex convertedModule) bindingValue + compactSource <- + expectRightWithLabel + "compact mixed wildcard render" + (renderFixtureModule "MixedRecordWildcard" convertedModule) + prettySource <- + expectRightWithLabel + "pretty mixed wildcard render" + ( renderSourceString + (PrettyLayout defaultPageWidth) + ( RenderConvertedModule + (ModuleRenderContext "" (Just "MixedRecordWildcard")) + convertedModule + ) + ) + traverse_ + ( \renderedSource -> do + assertBool + ("generated header must contain NamedFieldPuns exactly once:\n" <> renderedSource) + (countSubstring "{-# LANGUAGE NamedFieldPuns #-}" renderedSource == 1) + assertBool + ("generated header must contain RecordWildCards exactly once:\n" <> renderedSource) + (countSubstring "{-# LANGUAGE RecordWildCards #-}" renderedSource == 1) + assertBool + ("generated header must compose MultiWayIf exactly once:\n" <> renderedSource) + (countSubstring "{-# LANGUAGE MultiWayIf #-}" renderedSource == 1) + assertBool + ("mixed record syntax must retain pun and wildcard items:\n" <> renderedSource) + ("MkRec {explicit = renamed, pun, ..}" `isInfixOf` renderedSource) + reparsedModule <- + expectRightWithLabel + ("mixed wildcard reparse:\n" <> renderedSource) + ( convertHaskellSourceWithRecordFieldEnvironment + recordEnvironment + "MixedRecordWildcard.hs" + renderedSource + ) + reparsedBinding <- singleBinding reparsedModule + assertRoundTripBinding renderedSource (bindingValue, reparsedBinding) + ) + [compactSource, prettySource], + testCase "ambiguous constructor evidence obstructs locally without poisoning unrelated constructors" $ do + let ambiguousEnvironment = + recordFieldEnvironmentFromStrings + [ ("MkRec", ["left"]), + ("MkRec", ["right"]) + ] + unrelatedAmbiguityEnvironment = + recordFieldEnvironmentFromStrings + [ ("Other", ["first"]), + ("Other", ["second"]), + ("MkRec", ["left"]) + ] + sourceText = + unlines + [ "{-# LANGUAGE RecordWildCards #-}", + "module AmbiguousWildcard where", + "record value = case value of { MkRec {..} -> left }" + ] + case + convertHaskellSourceWithRecordFieldEnvironment + ambiguousEnvironment + "AmbiguousWildcard.hs" + sourceText + of + Left + ( ConvertRecordWildcardResolutionUnavailable + wildcardRegion + (RecordWildcardConstructorAmbiguous constructorName) + ) -> do + srStartLine wildcardRegion @?= 3 + occNameString (rdrNameOcc constructorName) @?= "MkRec" + Left obstruction -> + assertFailure + ("expected ambiguous record-wildcard evidence, got " <> show obstruction) + Right _ -> + assertFailure "expected ambiguous record-wildcard evidence, got successful conversion" + convertedModule <- + expectRightWithLabel + "unrelated ambiguity conversion" + ( convertHaskellSourceWithRecordFieldEnvironment + unrelatedAmbiguityEnvironment + "AmbiguousWildcard.hs" + sourceText + ) + bindingValue <- singleBinding convertedModule + patternLocalReferences (tlbTerm bindingValue) @?= [BinderId 1, BinderId 2], + testCase "qualified record puns preserve qualified field identity and an unqualified local binder" $ do + convertedModule <- + expectRightWithLabel + "qualified record pun conversion" + ( convertHaskellSource + "QualifiedRecordPun.hs" + ( unlines + [ "{-# LANGUAGE NamedFieldPuns #-}", + "module QualifiedRecordPun where", + "record value = case value of { MkRec { Qualified.field } -> field }" + ] + ) + ) + bindingValue <- singleBinding convertedModule + case stripBindingLambdas (tlbTerm bindingValue) of + PatternNode + ( CaseF + _ + [ (PRecP _ [HsRecPatField fieldName (HsRecPatPun punBinder)], PatternNode (VarF (LocalName bodyBinder))) + ] + ) -> do + renderRdrName fieldName @?= "Qualified.field" + occNameString (rdrNameOcc (baName punBinder)) @?= "field" + baId punBinder @?= baId bodyBinder + bodyPattern -> + assertFailure + ("expected a qualified field key with an unqualified pun binder, got " <> show bodyPattern) + renderedSource <- + expectRightWithLabel + "qualified record pun render" + (renderFixtureModule "QualifiedRecordPun" convertedModule) + assertBool + ("qualified record pun must remain qualified:\n" <> renderedSource) + ("MkRec {Qualified.field}" `isInfixOf` renderedSource), + testCase "render-round-trip record equivalence is ordered and syntax-structural" $ do + let constructorName = mkRdrUnqual (mkDataOcc "MkRec") + firstField = mkRdrUnqual (mkVarOcc "first") + secondField = mkRdrUnqual (mkVarOcc "second") + leftFirst = BinderAnn (BinderId 10) (mkRdrUnqual (mkVarOcc "leftFirst")) + leftSecond = BinderAnn (BinderId 11) (mkRdrUnqual (mkVarOcc "leftSecond")) + rightFirst = BinderAnn (BinderId 20) (mkRdrUnqual (mkVarOcc "rightFirst")) + rightSecond = BinderAnn (BinderId 21) (mkRdrUnqual (mkVarOcc "rightSecond")) + leftRegion = SourceRegion 1 1 1 3 + rightRegion = SourceRegion 9 4 9 6 + clauseTerm recordItems bodyBinder = + PatternNode + ( ClausesF + [ ( [PRecP constructorName recordItems], + PatternNode (VarF (LocalName bodyBinder)) + ) + ] + ) + orderedLeft = + [ HsRecPatField firstField (HsRecPatExplicit (PVarP leftFirst)), + HsRecPatField secondField (HsRecPatExplicit (PVarP leftSecond)) + ] + orderedRight = + [ HsRecPatField firstField (HsRecPatExplicit (PVarP rightFirst)), + HsRecPatField secondField (HsRecPatExplicit (PVarP rightSecond)) + ] + reorderedRight = + [ HsRecPatField secondField (HsRecPatExplicit (PVarP rightSecond)), + HsRecPatField firstField (HsRecPatExplicit (PVarP rightFirst)) + ] + punLeft = + [HsRecPatField firstField (HsRecPatPun leftFirst)] + explicitRight = + [HsRecPatField firstField (HsRecPatExplicit (PVarP rightFirst))] + wildcardLeft = + [HsRecPatWildcard leftRegion [leftFirst]] + wildcardRight = + [HsRecPatWildcard rightRegion [rightFirst]] + assertBool + "ordered explicit record items must alpha-compare" + (renderRoundTripEquivalent (clauseTerm orderedLeft leftFirst) (clauseTerm orderedRight rightFirst)) + assertBool + "record field reordering is not render-round-trip syntax equivalence" + (not (renderRoundTripEquivalent (clauseTerm orderedLeft leftFirst) (clauseTerm reorderedRight rightFirst))) + assertBool + "pun syntax does not collapse into explicit-self syntax" + (not (renderRoundTripEquivalent (clauseTerm punLeft leftFirst) (clauseTerm explicitRight rightFirst))) + assertBool + "wildcard token regions are provenance, not syntax identity" + (renderRoundTripEquivalent (clauseTerm wildcardLeft leftFirst) (clauseTerm wildcardRight rightFirst)) + assertBool + "wildcard presence cannot disappear" + (not (renderRoundTripEquivalent (clauseTerm wildcardLeft leftFirst) (clauseTerm [] rightFirst))) + assertBool + "wildcard position is syntax-structural" + ( not + ( renderRoundTripEquivalent + (clauseTerm (orderedLeft <> wildcardLeft) leftFirst) + (clauseTerm (wildcardRight <> orderedRight) rightFirst) + ) + ), + testCase "guard pattern equivalence uses the same ordered record relation" $ do + let constructorName = mkRdrUnqual (mkDataOcc "MkRec") + punField = mkRdrUnqual (mkVarOcc "punField") + wildcardField = mkRdrUnqual (mkVarOcc "wildcardField") + scrutineeName = mkRdrUnqual (mkVarOcc "scrutinee") + leftPun = BinderAnn (BinderId 30) punField + leftWildcard = BinderAnn (BinderId 31) wildcardField + rightPun = BinderAnn (BinderId 40) punField + rightWildcard = BinderAnn (BinderId 41) wildcardField + leftPattern = + PRecP + constructorName + [ HsRecPatField punField (HsRecPatPun leftPun), + HsRecPatWildcard (SourceRegion 2 5 2 7) [leftWildcard] + ] + rightPattern = + PRecP + constructorName + [ HsRecPatField punField (HsRecPatPun rightPun), + HsRecPatWildcard (SourceRegion 8 3 8 5) [rightWildcard] + ] + scrutinee = + PatternNode (VarF (GlobalName scrutineeName)) + localReference binderAnn = + PatternNode (VarF (LocalName binderAnn)) + leftPatternGuards = + [ GuardPatF leftPattern scrutinee, + GuardBoolF (localReference leftWildcard) + ] + rightPatternGuards = + [ GuardPatF rightPattern scrutinee, + GuardBoolF (localReference rightWildcard) + ] + leftLetGuards = + [ GuardLetF NonRecursiveBinds [(leftPattern, scrutinee)], + GuardBoolF (localReference leftPun) + ] + rightLetGuards = + [ GuardLetF NonRecursiveBinds [(rightPattern, scrutinee)], + GuardBoolF (localReference rightPun) + ] + assertBool + "GuardPatF threads pun and wildcard binders through the Pale relation" + (renderRoundTripGuardStatementsEquivalent leftPatternGuards rightPatternGuards) + assertBool + "GuardLetF threads pun and wildcard binders through the Pale relation" + (renderRoundTripGuardStatementsEquivalent leftLetGuards rightLetGuards), + testCase "constructor-pattern case alternatives convert to PConP, not lossy shapes" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "unwrap m = case m of { Just x -> x; Nothing -> fallback }" + ] + ) + ) + bindingValue <- singleBinding convertedModule + case stripBindingLambdas (tlbTerm bindingValue) of + PatternNode (CaseF _ branchValues) -> + case fmap fst branchValues of + [PConP _ [PVarP _], PConP _ []] -> + pure () + alternativePatterns -> + assertFailure + ("expected faithful constructor patterns, got " <> show alternativePatterns) + _ -> + assertFailure "expected the fixture body to convert to a case expression", + testCase "binder-bearing view patterns are typed conversion obstructions" $ + case + convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "viewed x = case x of { (project -> y) -> use y }" + ] + ) + of + Left (ConvertUnsupportedPattern (Just _) PatOpaqueView) -> + pure () + _ -> + assertFailure "expected a region-bearing view-pattern obstruction", + testCase "unsupported pattern kinds remain distinct typed obstructions" $ do + let viewResult = + convertHaskellSource + "Fixture.hs" + (unlines ["module Fixture where", "lossy x = case x of { (project -> y) -> use y }"]) + plusKResult = + convertHaskellSource + "Fixture.hs" + (unlines ["{-# LANGUAGE NPlusKPatterns #-}", "module Fixture where", "lossy x = case x of { (y + 1) -> use y }"]) + case (viewResult, plusKResult) of + ( Left (ConvertUnsupportedPattern _ PatOpaqueView), + Left (ConvertUnsupportedPattern _ PatOpaqueNPlusK) + ) -> + pure () + _ -> + assertFailure "expected distinct view and n-plus-k obstructions", + testCase "where pattern bindings convert without opaque local-binds fallback" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "clear x = combine a b where (a, b) = splitPair x" + ] + ) + ) + bindingValue <- singleBinding convertedModule + case tlbBinding bindingValue of + FunctionBinding _ (Clause _ (UnguardedRhs _ (Just bindingGroup)) :| []) -> + case bindingGroupBindings bindingGroup of + PatternBinding headPattern _ :| [] -> + case stripTestPatParens headPattern of + PTupleP BoxedTuple [PVarP _, PVarP _] -> + pure () + otherPattern -> + assertFailure ("expected a tuple pattern where binding, got " <> show otherPattern) + otherBindings -> + assertFailure ("expected one pattern binding in the canonical where group, got " <> show otherBindings) + otherBinding -> + assertFailure ("expected a function binding with a canonical where group, got " <> show otherBinding), + testCase "var let binding rows render byte-identically" $ do + let binderAnn = BinderAnn (BinderId 0) (mkRdrUnqual (mkVarOcc "y")) + renderSourceString + CompactLayout + ( RenderRewriteExpression + ( PatternNode + ( LetF + NonRecursiveBinds + [(PVarP binderAnn, PatternNode (OverLitF (NormalizedIntegralOverLit (exactIntegralFromInteger 1))))] + (PatternNode (VarF (LocalName binderAnn))) + ) + ) + ) + @?= Right "let y = 1 in y", + testCase "render refuses pattern variables and empty names" $ do + renderSourceString + CompactLayout + (RenderRewriteExpression (PatternVar (EGraph.mkPatternVar 0))) + @?= Left RenderPatternVariable + renderSourceString + CompactLayout + ( RenderNamedRewriteBinding + "" + (PatternNode (OverLitF (NormalizedIntegralOverLit (exactIntegralFromInteger 1)))) + ) + @?= Left RenderEmptyBindingName, + testCase "prim literals render with their hash-suffixed forms" $ do + renderSourceString + CompactLayout + (RenderRewriteExpression (PatternNode (LitF (NormalizedIntPrim (exactIntegralFromInteger 5))))) + @?= Right "5#" + renderSourceString + CompactLayout + (RenderRewriteExpression (PatternNode (LitF (NormalizedWordPrim (exactIntegralFromInteger 5))))) + @?= Right "5##" + renderSourceString + CompactLayout + (RenderRewriteExpression (PatternNode (LitF (NormalizedDoublePrim (exactFractionalFromRational (5 / 2)))))) + @?= Right "2.5##" + renderSourceString + CompactLayout + (RenderRewriteExpression (PatternNode (LitF (NormalizedStringPrim (ByteString.pack [102, 111, 111, 0, 255]))))) + @?= Right "\"foo\\x0\\&\\xff\\&\"#", + testCase "top-level bindings carry ordered source regions" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "first = 1", + "", + "second x = x" + ] + ) + ) + case fmap tlbRegion (convertedModuleBindings convertedModule) of + [Just firstRegion, Just secondRegion] -> do + srStartLine firstRegion @?= 3 + srStartLine secondRegion @?= 5 + projectedBindings <- + expectRightWithLabel + "annotated binding projections" + (traverse (bindingExpr (cmScopeIndex convertedModule)) (convertedModuleBindings convertedModule)) + fmap exprRegion projectedBindings @?= [Just firstRegion, Just secondRegion] + assertBool + "regions must not overlap" + (srEndLine firstRegion <= srStartLine secondRegion) + regions -> + assertFailure ("expected two located bindings, got " <> show regions) + ] + +spanLockstepTests :: TestTree +spanLockstepTests = + testGroup + "pale.spans.lockstep" + [ testCase "the canonical annotated tree erases across renderable expression shapes" $ do + convertedModule <- + expectRightWithLabel + "fixture conversion" + ( convertHaskellSource + "Fixture.hs" + ( unlines + [ "module Fixture where", + "", + "lockstep flag action p = do { x <- action; let { y = case p of { (a, b) -> if flag then [a + b, -x] else [x]; _ -> [x] } }; pure (y, MkSettings { width = 3, label = \"wide\" }) }" + ] + ) + ) + assertBool "fixture must contain at least one binding" (not (null (convertedModuleBindings convertedModule))) + mapM_ + (assertSpannedBindingLockstep (cmScopeIndex convertedModule)) + (convertedModuleBindings convertedModule) + ] + +assertSpannedBindingLockstep :: ScopeIndex -> ConvertedValueBinding -> IO () +assertSpannedBindingLockstep scopeIndex bindingValue = do + projectedBinding <- + expectRightWithLabel + "annotated binding projection" + (bindingExpr scopeIndex bindingValue) + eraseExpr projectedBinding @?= tlbTerm bindingValue + +expressionMetricOracle :: Expr -> ExpressionMetricOracle +expressionMetricOracle expressionValue = + let nodeValue = exprNode expressionValue + childMetrics = foldMap expressionMetricOracle nodeValue + freeScopeCount = freeScopeSummarySize (exprFreeScopes expressionValue) + (globalRefIncrement, localRefIncrement) = + case nodeValue of + VarF (GlobalName _) -> (1, 0) + VarF (LocalName _) -> (0, 1) + _ -> (0, 0) + in ExpressionMetricOracle + { oracleScopedExprCount = + oracleScopedExprCount childMetrics + 1, + oracleGlobalVarRefCount = + oracleGlobalVarRefCount childMetrics + globalRefIncrement, + oracleLocalVarRefCount = + oracleLocalVarRefCount childMetrics + localRefIncrement, + oracleMaxFreeScopeCount = + max + (oracleMaxFreeScopeCount childMetrics) + freeScopeCount + } + +roundTripCase :: String -> [String] -> TestTree +roundTripCase caseName fixtureLines = + testCase caseName $ do + let sourceText = unlines fixtureLines + convertedModule <- expectRightWithLabel "fixture conversion" (convertHaskellSource "Fixture.hs" sourceText) + assertBool "fixture must contain at least one binding" (not (null (convertedModuleBindings convertedModule))) + renderedSource <- + expectRightWithLabel + "render" + (renderFixtureModule "Fixture" convertedModule) + reparsedModule <- + expectRightWithLabel + ("re-parse of rendered source:\n" <> renderedSource) + (convertHaskellSource "Fixture.hs" renderedSource) + length (convertedModuleBindings reparsedModule) @?= length (convertedModuleBindings convertedModule) + mapM_ + (assertRoundTripBinding renderedSource) + (zip (convertedModuleBindings convertedModule) (convertedModuleBindings reparsedModule)) + +assertRoundTripBinding :: String -> (ConvertedValueBinding, ConvertedValueBinding) -> IO () +assertRoundTripBinding renderedSource (originalBinding, reparsedBinding) = do + bindingNameStrings originalBinding @?= bindingNameStrings reparsedBinding + assertBool + ( "binding " + <> show (bindingNameStrings originalBinding) + <> " is not round-trip equivalent; rendered source:\n" + <> renderedSource + ) + (renderRoundTripEquivalent (tlbTerm originalBinding) (tlbTerm reparsedBinding)) + +bindingNameStrings :: ConvertedValueBinding -> [String] +bindingNameStrings = + fmap (occNameString . rdrNameOcc) . tlbNames + +tlbNames :: ConvertedValueBinding -> [RdrName] +tlbNames = + bindingNames . tlbBinding + +tlbTerm :: ConvertedValueBinding -> Pattern HsExprF +tlbTerm = + bindingPattern . tlbBinding + +singleBinding :: ConvertedModule -> IO ConvertedValueBinding +singleBinding convertedModule = + case convertedModuleBindings convertedModule of + [bindingValue] -> pure bindingValue + bindingValues -> assertFailure ("expected exactly one binding, got " <> show (length bindingValues)) + +assertSingletonBindingComponent :: + String -> + [String] -> + Int -> + BindingComponentRecursion -> + IO () +assertSingletonBindingComponent fixtureLabel bindingLines expectedBinderCount expectedRecursion = do + convertedModule <- + expectRightWithLabel + fixtureLabel + ( convertHaskellSource + "SingletonBindingComponent.hs" + (unlines ("module SingletonBindingComponent where" : bindingLines)) + ) + topLevelBinding <- singleBinding convertedModule + bindingGroup <- + case tlbBinding topLevelBinding of + FunctionBinding _ (Clause _ rhsValue :| []) -> + expectBindingGroup fixtureLabel rhsValue + otherBinding -> + assertFailure + (fixtureLabel <> ": expected one-clause function binding, got " <> show otherBinding) + case (bindingGroupBindings bindingGroup, bindingGroupComponents bindingGroup) of + (localBinding :| [], componentValue :| []) -> do + let expectedBinders = + Set.toList (Set.fromList (localBindingBinderIds localBinding)) + length expectedBinders @?= expectedBinderCount + bindingComponentRows componentValue @?= (0 :| []) + bindingComponentBinders componentValue @?= expectedBinders + bindingComponentDependencies componentValue @?= [] + bindingComponentRecursion componentValue @?= expectedRecursion + (localBindings, componentValues) -> + assertFailure + ( fixtureLabel + <> ": expected one local binding and one component, got " + <> show (NonEmpty.length localBindings, NonEmpty.length componentValues) + ) + +type BindingComponentEvidence = + ( NonEmpty Int, + [BinderId], + [BinderId], + BindingComponentRecursion + ) + +assertBindingComponentsMatchGraphOracle :: + (String, [String]) -> + IO () +assertBindingComponentsMatchGraphOracle (fixtureLabel, bindingLines) = do + convertedModule <- + expectRightWithLabel + fixtureLabel + ( convertHaskellSource + "BindingComponentDifferential.hs" + (unlines ("module BindingComponentDifferential where" : bindingLines)) + ) + topLevelBinding <- singleBinding convertedModule + bindingGroup <- + case tlbBinding topLevelBinding of + FunctionBinding _ (Clause _ rhsValue :| []) -> + expectBindingGroup fixtureLabel rhsValue + PatternBinding _ rhsValue -> + expectBindingGroup fixtureLabel rhsValue + otherBinding -> + assertFailure + (fixtureLabel <> ": expected one-clause binding, got " <> show otherBinding) + oracleComponents <- + either + (assertFailure . ((fixtureLabel <> ": ") <>)) + pure + (genericBindingComponentOracle bindingGroup) + fmap bindingComponentEvidence (NonEmpty.toList (bindingGroupComponents bindingGroup)) + @?= oracleComponents + +genericBindingComponentOracle :: + BindingGroup -> + Either String [BindingComponentEvidence] +genericBindingComponentOracle bindingGroup = + traverse + componentEvidenceFromScc + (stronglyConnComp dependencyNodes) + where + indexedBindings = + zip + [0 :: Int ..] + (NonEmpty.toList (bindingGroupBindings bindingGroup)) + binderOwnerRows = + Map.fromList + [ (binderId, rowIndex) + | (rowIndex, bindingValue) <- indexedBindings, + binderId <- localBindingBinderIds bindingValue + ] + groupBinderIds = + Map.keysSet binderOwnerRows + dependencyNodes = + fmap bindingDependencyNode indexedBindings + bindingDependencyNode (rowIndex, bindingValue) = + let bindingIds = + localBindingBinderIds bindingValue + dependencyIds = + Set.toList + ( Set.intersection + groupBinderIds + (Set.fromList (bindingLocalReferences bindingValue)) + ) + dependencyRows = + Set.toList + ( Set.fromList + ( foldMap + (\binderId -> maybe [] (: []) (Map.lookup binderId binderOwnerRows)) + dependencyIds + ) + ) + in ( (rowIndex, bindingIds, dependencyIds), + rowIndex, + dependencyRows + ) + +componentEvidenceFromScc :: + SCC (Int, [BinderId], [BinderId]) -> + Either String BindingComponentEvidence +componentEvidenceFromScc = \case + AcyclicSCC rowPayload -> + Right (componentEvidenceFromRows (rowPayload :| []) AcyclicBindingComponent) + CyclicSCC rowPayloads -> + maybe + (Left "generic SCC oracle returned an empty cyclic component") + (Right . (`componentEvidenceFromRows` RecursiveBindingComponent)) + (NonEmpty.nonEmpty rowPayloads) + +componentEvidenceFromRows :: + NonEmpty (Int, [BinderId], [BinderId]) -> + BindingComponentRecursion -> + BindingComponentEvidence +componentEvidenceFromRows rowPayloads recursionValue = + let componentRows = + fmap (\(rowIndex, _, _) -> rowIndex) rowPayloads + componentBinders = + Set.toList + ( foldMap + (Set.fromList . (\(_, binderIds, _) -> binderIds)) + rowPayloads + ) + binderSet = + Set.fromList componentBinders + externalDependencies = + foldMap + (Set.fromList . (\(_, _, dependencyIds) -> dependencyIds)) + rowPayloads + `Set.difference` binderSet + in ( componentRows, + componentBinders, + Set.toList externalDependencies, + recursionValue + ) + +bindingComponentEvidence :: BindingComponent -> BindingComponentEvidence +bindingComponentEvidence componentValue = + ( bindingComponentRows componentValue, + bindingComponentBinders componentValue, + bindingComponentDependencies componentValue, + bindingComponentRecursion componentValue + ) + +bindingLocalReferences :: Binding -> [BinderId] +bindingLocalReferences = + patternLocalReferences . bindingPattern + +patternLocalReferences :: Pattern HsExprF -> [BinderId] +patternLocalReferences = \case + PatternVar _ -> + [] + PatternNode nodeValue -> + [baId binderAnn | VarF (LocalName binderAnn) <- [nodeValue]] + <> foldMap patternLocalReferences nodeValue + +patternGlobalReferenceNames :: Pattern HsExprF -> [String] +patternGlobalReferenceNames = \case + PatternVar _ -> + [] + PatternNode nodeValue -> + [occNameString (rdrNameOcc globalName) | VarF (GlobalName globalName) <- [nodeValue]] + <> foldMap patternGlobalReferenceNames nodeValue + +recordFieldEnvironmentFromStrings :: + [(String, [String])] -> + RecordFieldEnvironment +recordFieldEnvironmentFromStrings = + recordFieldEnvironmentFromDefinitions + . fmap + ( \(constructorName, fieldNames) -> + ( mkRdrUnqual (mkDataOcc constructorName), + fmap (mkRdrUnqual . mkVarOcc) fieldNames + ) + ) + +countSubstring :: String -> String -> Int +countSubstring needle haystack = + Text.count (Text.pack needle) (Text.pack haystack) + +expectBindingGroup :: String -> Rhs -> IO BindingGroup +expectBindingGroup fixtureLabel = \case + UnguardedRhs _ (Just bindingGroup) -> + pure bindingGroup + otherRhs -> + assertFailure (fixtureLabel <> ": expected an unguarded RHS with local bindings, got " <> show otherRhs) + +localBindingBinderIds :: Binding -> [BinderId] +localBindingBinderIds = \case + FunctionBinding binderAnn _ -> + [baId binderAnn] + PatternBinding bindingPatternValue _ -> + fmap baId (patBinders bindingPatternValue) + +letRecursions :: Pattern HsExprF -> [LetRecursion] +letRecursions = \case + PatternVar {} -> + [] + PatternNode expressionNode -> + case expressionNode of + LetF letRecursion bindingRows bodyExpr -> + letRecursion + : foldMap (letRecursions . snd) bindingRows + <> letRecursions bodyExpr + otherExpressionNode -> + foldMap letRecursions otherExpressionNode + +stripBindingLambdas :: Pattern HsExprF -> Pattern HsExprF +stripBindingLambdas = \case + PatternNode (LamF _ bodyValue) -> stripBindingLambdas bodyValue + patternValue -> patternValue + +stripTestPatParens :: HsPatF -> HsPatF +stripTestPatParens = \case + PParP innerPattern -> stripTestPatParens innerPattern + patternValue -> patternValue + +patternContainsExprWithTySig :: Pattern HsExprF -> Bool +patternContainsExprWithTySig = \case + PatternVar {} -> False + PatternNode (ExprWithTySigF _ _) -> True + PatternNode layer -> any patternContainsExprWithTySig layer + +patternContainsAppType :: Pattern HsExprF -> Bool +patternContainsAppType = \case + PatternVar {} -> False + PatternNode (AppTypeF _ _) -> True + PatternNode layer -> any patternContainsAppType layer diff --git a/test/ghc-surface/Expr/SourceCoordinatesSpec.hs b/test/ghc-surface/Expr/SourceCoordinatesSpec.hs new file mode 100644 --- /dev/null +++ b/test/ghc-surface/Expr/SourceCoordinatesSpec.hs @@ -0,0 +1,70 @@ +module Expr.SourceCoordinatesSpec (tests) where + +import Moonlight.Pale.Ghc.Expr + ( SourceEndConvention (..), + SourceRangeFailure (..), + SourceRegion (..), + sourceCharRangeEnd, + sourceCharRangeRegion, + sourceCharRangeStart, + sourceCharRangeText, + sourceRegionCharRangeWith, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertEqual, assertFailure, testCase) + +tests :: TestTree +tests = + testGroup + "profile-rewrite.coordinates" + [ testCase "tab-aware half-open coordinates retain Unicode scalar offsets" $ do + resolved <- requireRight (sourceRegionCharRangeWith 8 SourceEndHalfOpen canonicalSource (SourceRegion 1 1 1 13)) + assertEqual "start" 0 (sourceCharRangeStart resolved) + assertEqual "end" 6 (sourceCharRangeEnd resolved) + assertEqual "slice" (Right "α\tbeta") (sourceCharRangeText canonicalSource resolved), + testCase "tab-aware inclusive coordinates consume the final source character" $ do + resolved <- requireRight (sourceRegionCharRangeWith 8 SourceEndInclusive canonicalSource (SourceRegion 1 9 1 12)) + assertEqual "start" 2 (sourceCharRangeStart resolved) + assertEqual "end" 6 (sourceCharRangeEnd resolved) + assertEqual "slice" (Right "beta") (sourceCharRangeText canonicalSource resolved), + testCase "coordinates inside a tab expansion are noninvertible" $ + assertEqual + "inside tab" + (Left (SourceRangePositionInsideTab 1 3)) + (sourceRegionCharRangeWith 8 SourceEndHalfOpen canonicalSource (SourceRegion 1 3 1 9)), + testCase "cross-line half-open coordinates preserve the newline" $ do + let expectedRegion = SourceRegion 1 9 2 2 + resolved <- requireRight (sourceRegionCharRangeWith 8 SourceEndHalfOpen canonicalSource expectedRegion) + assertEqual "slice" (Right "beta\nz") (sourceCharRangeText canonicalSource resolved) + assertEqual "inverse region" (Right expectedRegion) (sourceCharRangeRegion canonicalSource resolved), + testCase "tab-aware range inversion returns visual columns" $ do + let expectedRegion = SourceRegion 1 9 1 13 + resolved <- requireRight (sourceRegionCharRangeWith 8 SourceEndHalfOpen canonicalSource expectedRegion) + assertEqual "visual-column inverse" (Right expectedRegion) (sourceCharRangeRegion canonicalSource resolved), + testCase "CRLF source is refused" $ + assertEqual + "CRLF" + (Left SourceRangeCarriageReturnUnsupported) + (sourceRegionCharRangeWith 8 SourceEndHalfOpen "x\r\ny\n" (SourceRegion 1 1 1 2)), + testCase "bare carriage returns are refused" $ + assertEqual + "bare CR" + (Left SourceRangeCarriageReturnUnsupported) + (sourceRegionCharRangeWith 8 SourceEndHalfOpen "x\ry" (SourceRegion 1 1 1 2)), + testCase "invalid tab stops are refused before conversion" $ + assertEqual + "tab stop" + (Left (SourceRangeInvalidTabStop 0)) + (sourceRegionCharRangeWith 0 SourceEndHalfOpen canonicalSource (SourceRegion 1 1 1 2)), + testCase "inclusive coordinates cannot name the boundary after a line" $ + assertEqual + "inclusive boundary" + (Left (SourceRangePositionOutsideSource 1 13)) + (sourceRegionCharRangeWith 8 SourceEndInclusive canonicalSource (SourceRegion 1 9 1 13)) + ] + +canonicalSource :: String +canonicalSource = "α\tbeta\nz\n" + +requireRight :: Show failure => Either failure value -> IO value +requireRight = either (assertFailure . show) pure diff --git a/test/ghc-surface/Hie/OracleSpec.hs b/test/ghc-surface/Hie/OracleSpec.hs new file mode 100644 --- /dev/null +++ b/test/ghc-surface/Hie/OracleSpec.hs @@ -0,0 +1,677 @@ +module Hie.OracleSpec (tests) where + +import Control.Exception (bracket) +import Control.Monad (replicateM) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as ByteStringChar8 +import Data.Char (isAlpha, toUpper) +import Data.List (find, intercalate, isSuffixOf, stripPrefix) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Set qualified as Set +import GHC.Clock (getMonotonicTimeNSec) +import Moonlight.Pale.Ghc.Hie.Oracle (ModuleNameOracle (..), ResolvedOrigin, mkResolvedOrigin, occResolvesUniquely) +import Moonlight.Pale.Ghc.Hie.Read (HieReadError (..), indexHieRoots) +import Moonlight.Pale.Ghc.Hie.SourceKey + ( HieOracleArtifact (..), + HieSourceKeyKind (..), + OracleLookup (..), + OracleQuery (..), + TriedKey (..), + buildHieOracleIndex, + lookupModuleOracle, + ) +import Moonlight.Pale.TestSupport.CompileHieFixture + ( CompiledHieFixture (compiledHieFixtureOracle), + compileHieFixture, + mkHieFixtureModuleName, + ) +import System.Directory + ( createDirectoryIfMissing, + createDirectoryLink, + getTemporaryDirectory, + removePathForcibly, + ) +import System.Exit (ExitCode (..)) +import System.FilePath (normalise, takeFileName, ()) +import System.Process (readProcessWithExitCode) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase) + +tests :: TestTree +tests = + testGroup + "pale.hie.oracle" + [ testCase "ghc hie resolves map and composition into accepted base origins" $ do + artifact <- compileAndReadArtifact "OracleFixture" oracleFixtureSource + let oracle = hieArtifactOracle artifact + acceptedMapOrigins <- acceptedOriginsFor "map" + acceptedComposeOrigins <- acceptedOriginsFor "." + assertBool + "HIE discovery retains the selected artifact path" + (takeFileName (hieArtifactPath artifact) == "OracleFixture.hie") + assertBool "map resolves through the base registry" (occResolvesUniquely oracle "map" acceptedMapOrigins) + assertBool "composition resolves through the base registry" (occResolvesUniquely oracle "." acceptedComposeOrigins) + assertBool "hie evidence variables are decoded into span-indexed evidence" (not (Map.null (mnoEvidenceAtSpan oracle))) + assertBool "hie type table is flattened into span-indexed oracle words" (not (Map.null (mnoTypeAtSpan oracle))), + testCase "a user-defined composition operator is not accepted as base composition" $ do + oracle <- compileAndReadOracle "ShadowFixture" shadowFixtureSource + acceptedComposeOrigins <- acceptedOriginsFor "." + assertBool "shadowed composition does not satisfy the base registry" (not (occResolvesUniquely oracle "." acceptedComposeOrigins)), + testCase "source-key lookup uses suffix fallback without guessing through ambiguities" $ do + let artifact = emptyArtifact "src/Foo/Bar.hs" + oracleIndex = buildHieOracleIndex [artifact] + lookupResult = + lookupModuleOracle + oracleIndex + OracleQuery + { oqGivenPath = "compiler/foundation/demo/src/Foo/Bar.hs", + oqAbsolutePath = Nothing, + oqSourceRoots = [] + } + case lookupResult of + OracleFound ModuleSuffixKey foundArtifact -> + assertBool + "lookup returns the selected HIE artifact" + (hieArtifactPath foundArtifact == hieArtifactPath artifact) + other -> + assertFailure ("expected module suffix hit, got " <> show other), + testCase "source-key lookup prefers exact keys over suffix keys" $ do + let exactArtifact = emptyArtifact "app/Foo.hs" + suffixArtifact = emptyArtifact "src/Foo.hs" + oracleIndex = buildHieOracleIndex [exactArtifact, suffixArtifact] + case lookupModuleOracle oracleIndex (OracleQuery "app/Foo.hs" Nothing []) of + OracleFound GivenPathKey _ -> + pure () + other -> + assertFailure ("expected exact hit before suffix fallback, got " <> show other), + testCase "source-key lookup attaches root-relative paths before suffix fallback" $ do + let oracleIndex = buildHieOracleIndex [emptyArtifact "src/Foo.hs"] + case lookupModuleOracle oracleIndex (OracleQuery "/workspace/pkg/src/Foo.hs" Nothing ["/workspace/pkg"]) of + OracleFound RootRelativeKey _ -> + pure () + other -> + assertFailure ("expected root-relative hit, got " <> show other), + testCase "source-key lookup stops at the longest matching suffix before shorter ambiguities" $ do + let oracleIndex = + buildHieOracleIndex + [ emptyArtifact "pkg-a/src/Foo.hs", + emptyArtifact "pkg-b/src/Foo.hs", + emptyArtifact "other/Foo.hs" + ] + case lookupModuleOracle oracleIndex (OracleQuery "/workspace/pkg-a/src/Foo.hs" Nothing []) of + OracleFound ModuleSuffixKey _ -> + pure () + other -> + assertFailure ("expected longest singleton suffix hit, got " <> show other), + testCase "source-key lookup reports exact-key ambiguity" $ do + let firstArtifact = HieOracleArtifact "first/Foo.hie" (emptyOracle "src/Foo.hs") + secondArtifact = HieOracleArtifact "second/Foo.hie" (emptyOracle "src/Foo.hs") + oracleIndex = buildHieOracleIndex [firstArtifact, secondArtifact] + case lookupModuleOracle oracleIndex (OracleQuery "src/Foo.hs" Nothing []) of + OracleAmbiguous GivenPathKey "src/Foo.hs" candidates -> + assertBool + "ambiguous exact lookup carries artifact paths" + (candidates == ["first/Foo.hie", "second/Foo.hie"]) + other -> + assertFailure ("expected exact ambiguity, got " <> show other), + testCase "source-key lookup records tried keys for misses" $ do + let oracleIndex = buildHieOracleIndex [emptyArtifact "src/Foo.hs"] + case lookupModuleOracle oracleIndex (OracleQuery "src/Bar.hs" Nothing []) of + OracleMissing triedKeys -> + assertBool + "miss reports exact identity before suffix identities" + ( take 3 triedKeys + == [ TriedKey GivenPathKey "src/Bar.hs", + TriedKey ModuleSuffixKey "src/Bar.hs", + TriedKey ModuleSuffixKey "Bar.hs" + ] + ) + other -> + assertFailure ("expected miss, got " <> show other), + testCase "source-key lookup preserves relative versus POSIX-root anchors" $ do + let oracleIndex = buildHieOracleIndex [emptyArtifact "src/Foo.hs"] + case lookupModuleOracle oracleIndex (OracleQuery "/src/Foo.hs" Nothing []) of + OracleFound ModuleSuffixKey _ -> + pure () + other -> + assertFailure ("expected anchored path to require suffix lookup, got " <> show other), + testCase "source-key lookup canonicalizes drive-root anchors" $ do + let oracleIndex = buildHieOracleIndex [emptyArtifact "C:\\workspace\\src\\Foo.hs"] + case lookupModuleOracle oracleIndex (OracleQuery "c:/workspace/src/Foo.hs" Nothing []) of + OracleFound GivenPathKey _ -> + pure () + other -> + assertFailure ("expected drive-root exact hit, got " <> show other), + testCase "source-key lookup preserves UNC anchors" $ do + let oracleIndex = buildHieOracleIndex [emptyArtifact "\\\\server\\share\\src\\Foo.hs"] + case lookupModuleOracle oracleIndex (OracleQuery "//server/share/src/Foo.hs" Nothing []) of + OracleFound GivenPathKey _ -> + pure () + other -> + assertFailure ("expected UNC exact hit, got " <> show other), + testCase "source-key trie agrees with the exhaustive normalized-list oracle" $ do + assertBool + "bounded corpus generator must retain 2,380 ordered corpora" + (length sourceKeyOracleCorpora == 2380) + assertBool + "query matrix must retain all 27 structural lookup contexts" + (length sourceKeyDifferentialQueries == 27) + case sourceKeyDifferentialFailure of + Nothing -> + pure () + Just failure -> + assertFailure failure, + testCase "HIE discovery canonicalizes duplicate directory and file roots" $ + withFreshTestDirectory "duplicate-roots" $ \root -> do + let invalidHiePath = root "Invalid.hie" + writeFile invalidHiePath "" + (failures, _oracleIndex) <- + indexHieRoots + [ root, + root ".", + invalidHiePath + ] + case failures of + [HieReadError _ _] -> + pure () + other -> + assertFailure ("expected one canonicalized artifact failure, got " <> show other), + testCase "HIE discovery does not follow directory symlink cycles" $ + withFreshTestDirectory "directory-symlink-cycle" $ \root -> do + let nestedDirectory = root "nested" + invalidHiePath = nestedDirectory "Invalid.hie" + cyclePath = nestedDirectory "cycle" + createDirectoryIfMissing True nestedDirectory + writeFile invalidHiePath "" + createDirectoryLink root cyclePath + (failures, _oracleIndex) <- indexHieRoots [root] + case failures of + [HieReadError _ _] -> + pure () + other -> + assertFailure ("expected one artifact failure without cycle traversal, got " <> show other), + testCase "ordinary global uses retain exact source spans" $ do + fixtureModuleName <- + case mkHieFixtureModuleName "SpanFixture" of + Left failure -> + assertFailure ("fixture module name rejected: " <> show failure) + Right value -> + pure value + fixtureResult <- + compileHieFixture fixtureModuleName spanFixtureSource + fixture <- + case fixtureResult of + Left failure -> + assertFailure ("HIE fixture compilation failed: " <> show failure) + Right value -> + pure value + let useRows = + [ (region, origins) + | (region, names) <- Map.toList (mnoGlobalUsesAtSpan (compiledHieFixtureOracle fixture)), + Just origins <- [Map.lookup "map" names] + ] + assertBool "ordinary map uses are indexed at more than one exact span" (length useRows >= 2) + assertBool "each exact map span resolves to one origin" (all ((== 1) . Set.size . snd) useRows) + ] + +spanFixtureSource :: ByteString +spanFixtureSource = + ByteStringChar8.pack + ( unlines + [ "module SpanFixture where", + "first = map id []", + "second = map id []" + ] + ) + +withFreshTestDirectory :: FilePath -> (FilePath -> IO value) -> IO value +withFreshTestDirectory label action = do + temporaryDirectory <- getTemporaryDirectory + uniqueSuffix <- show <$> getMonotonicTimeNSec + let root = + temporaryDirectory + "pale-hie-traversal-spec" + (label <> "-" <> uniqueSuffix) + prepare = do + createDirectoryIfMissing True root + pure root + bracket prepare removePathForcibly action + +emptyOracle :: FilePath -> ModuleNameOracle +emptyOracle sourcePath = + oracleAt (normalise sourcePath) + +emptyArtifact :: FilePath -> HieOracleArtifact +emptyArtifact sourcePath = + HieOracleArtifact + { hieArtifactPath = sourcePath <> ".hie", + hieArtifactOracle = emptyOracle sourcePath + } + +oracleAt :: FilePath -> ModuleNameOracle +oracleAt sourcePath = + ModuleNameOracle + { mnoSourcePath = sourcePath, + mnoGlobalUsesAtSpan = Map.empty, + mnoGlobalUses = Map.empty, + mnoEvidenceAtSpan = Map.empty, + mnoTypeAtSpan = Map.empty + } + +data SlowPathAnchor + = SlowRelativeAnchor + | SlowPosixRootAnchor + | SlowDriveRootAnchor !Char + | SlowUncRootAnchor !String !String + deriving stock (Eq, Ord, Show) + +data SlowCanonicalPath = SlowCanonicalPath + { slowPathAnchor :: !SlowPathAnchor, + slowPathComponents :: ![FilePath] + } + deriving stock (Eq, Ord, Show) + +sourceKeyDifferentialFailure :: Maybe String +sourceKeyDifferentialFailure = + foldr compareCorpus Nothing sourceKeyOracleCorpora + where + compareCorpus sourcePaths nextFailure = + let artifacts = fmap artifactAt sourcePaths + oracleIndex = buildHieOracleIndex artifacts + in case + find + ( \query -> + lookupModuleOracle oracleIndex query + /= slowLookupModuleOracle artifacts query + ) + sourceKeyDifferentialQueries + of + Nothing -> + nextFailure + Just query -> + let expected = slowLookupModuleOracle artifacts query + actual = lookupModuleOracle oracleIndex query + in Just + ( "source-key differential failed" + <> "\ncorpus: " + <> show sourcePaths + <> "\nquery: " + <> show query + <> "\nexpected: " + <> show expected + <> "\nactual: " + <> show actual + ) + +artifactAt :: FilePath -> HieOracleArtifact +artifactAt sourcePath = + HieOracleArtifact + { hieArtifactPath = "hie/" <> show sourcePath <> ".hie", + hieArtifactOracle = oracleAt sourcePath + } + +sourceKeyOracleCorpora :: [[FilePath]] +sourceKeyOracleCorpora = + concatMap + (`replicateM` sourceKeyPathUniverse) + [0 .. 3] + +sourceKeyPathUniverse :: [FilePath] +sourceKeyPathUniverse = + [ "src/Foo.hs", + "./src/./Foo.hs", + "app/Foo.hs", + "pkg-a/src/Foo.hs", + "pkg-b/src/Foo.hs", + "other/Foo.hs", + "/workspace/pkg/src/Foo.hs", + "/other/pkg/src/Foo.hs", + "C:\\workspace\\src\\Foo.hs", + "c:/workspace/src/Foo.hs", + "\\\\server\\share\\src\\Foo.hs", + "//server/share/src/Foo.hs", + "src/Bar.hs" + ] + +sourceKeyDifferentialQueries :: [OracleQuery] +sourceKeyDifferentialQueries = + fmap (\sourcePath -> OracleQuery sourcePath Nothing []) sourceKeyPathUniverse + <> [ OracleQuery + { oqGivenPath = "app/Foo.hs", + oqAbsolutePath = Just "/workspace/pkg/src/Foo.hs", + oqSourceRoots = ["/workspace/pkg"] + }, + OracleQuery + { oqGivenPath = "missing/Foo.hs", + oqAbsolutePath = Just "/workspace/pkg/src/Foo.hs", + oqSourceRoots = ["/workspace/pkg"] + }, + OracleQuery + { oqGivenPath = "/workspace/pkg/src/Foo.hs", + oqAbsolutePath = Nothing, + oqSourceRoots = ["/workspace/pkg"] + }, + OracleQuery + { oqGivenPath = "/workspace/pkg/src/Foo.hs", + oqAbsolutePath = Nothing, + oqSourceRoots = ["/workspace", "/workspace/pkg"] + }, + OracleQuery + { oqGivenPath = "c:/workspace/src/Foo.hs", + oqAbsolutePath = Nothing, + oqSourceRoots = ["C:\\workspace"] + }, + OracleQuery + { oqGivenPath = "//server/share/src/Foo.hs", + oqAbsolutePath = Nothing, + oqSourceRoots = ["\\\\server\\share"] + }, + OracleQuery "/checkout/pkg-a/src/Foo.hs" Nothing [], + OracleQuery "/checkout/src/Foo.hs" Nothing [], + OracleQuery "/checkout/Foo.hs" Nothing [], + OracleQuery + { oqGivenPath = "/workspace/src/Missing.hs", + oqAbsolutePath = Just "/workspace/src/Missing.hs", + oqSourceRoots = ["/workspace"] + }, + OracleQuery "pkg/../src/./Foo.hs" Nothing [], + OracleQuery "/src/Foo.hs" Nothing [], + OracleQuery "c:/workspace/src/Foo.hs" Nothing [], + OracleQuery "//server/share/src/Foo.hs" Nothing [] + ] + +slowLookupModuleOracle :: [HieOracleArtifact] -> OracleQuery -> OracleLookup +slowLookupModuleOracle artifacts query = + case slowFirstExactLookup artifacts (slowExactQueryKeys query) of + Just exactLookup -> + exactLookup + Nothing -> + case + find + (not . null . (`slowSuffixCandidates` artifacts)) + (slowComponentSuffixes (slowPathComponents (slowCanonicalPath (oqGivenPath query)))) + of + Nothing -> + OracleMissing (slowExactTriedKeys query <> slowSuffixTriedKeys query) + Just matchedComponents -> + slowLookupOutcome + ModuleSuffixKey + (intercalate "/" matchedComponents) + (slowSuffixCandidates matchedComponents artifacts) + +slowFirstExactLookup :: + [HieOracleArtifact] -> + [(HieSourceKeyKind, SlowCanonicalPath)] -> + Maybe OracleLookup +slowFirstExactLookup artifacts = + foldr + ( \(keyKind, pathValue) nextLookup -> + case slowExactCandidates pathValue artifacts of + [] -> + nextLookup + candidates -> + Just + ( slowLookupOutcome + keyKind + (slowRenderCanonicalPath pathValue) + candidates + ) + ) + Nothing + +slowLookupOutcome :: + HieSourceKeyKind -> + FilePath -> + [HieOracleArtifact] -> + OracleLookup +slowLookupOutcome keyKind matchedKey candidates = + case candidates of + [] -> + OracleMissing [TriedKey keyKind matchedKey] + [artifact] -> + OracleFound keyKind artifact + ambiguous -> + OracleAmbiguous keyKind matchedKey (fmap hieArtifactPath ambiguous) + +slowExactCandidates :: + SlowCanonicalPath -> + [HieOracleArtifact] -> + [HieOracleArtifact] +slowExactCandidates pathValue = + filter + ( (== pathValue) + . slowCanonicalPath + . mnoSourcePath + . hieArtifactOracle + ) + +slowSuffixCandidates :: + [FilePath] -> + [HieOracleArtifact] -> + [HieOracleArtifact] +slowSuffixCandidates suffixComponents = + filter + ( (suffixComponents `isSuffixOf`) + . slowPathComponents + . slowCanonicalPath + . mnoSourcePath + . hieArtifactOracle + ) + +slowExactQueryKeys :: OracleQuery -> [(HieSourceKeyKind, SlowCanonicalPath)] +slowExactQueryKeys query = + [(GivenPathKey, slowCanonicalPath (oqGivenPath query))] + <> maybe + [] + (\absolutePath -> [(AbsolutePathKey, slowCanonicalPath absolutePath)]) + (oqAbsolutePath query) + <> fmap (\relativePath -> (RootRelativeKey, relativePath)) (slowRootRelativePaths query) + +slowExactTriedKeys :: OracleQuery -> [TriedKey] +slowExactTriedKeys = + mapMaybe + ( \(keyKind, pathValue) -> + case slowRenderCanonicalPath pathValue of + "" -> + Nothing + renderedPath -> + Just (TriedKey keyKind renderedPath) + ) + . slowExactQueryKeys + +slowRootRelativePaths :: OracleQuery -> [SlowCanonicalPath] +slowRootRelativePaths query = + [ relativePath + | root <- fmap slowCanonicalPath (oqSourceRoots query), + pathValue <- + slowCanonicalPath (oqGivenPath query) + : maybe [] (pure . slowCanonicalPath) (oqAbsolutePath query), + Just relativePath <- [slowStripCanonicalRoot root pathValue] + ] + +slowStripCanonicalRoot :: + SlowCanonicalPath -> + SlowCanonicalPath -> + Maybe SlowCanonicalPath +slowStripCanonicalRoot root pathValue + | slowPathAnchor root /= slowPathAnchor pathValue = + Nothing + | otherwise = + SlowCanonicalPath SlowRelativeAnchor + <$> stripPrefix + (slowPathComponents root) + (slowPathComponents pathValue) + +slowSuffixTriedKeys :: OracleQuery -> [TriedKey] +slowSuffixTriedKeys = + fmap (TriedKey ModuleSuffixKey . intercalate "/") + . slowComponentSuffixes + . slowPathComponents + . slowCanonicalPath + . oqGivenPath + +slowComponentSuffixes :: [FilePath] -> [[FilePath]] +slowComponentSuffixes components = + case components of + [] -> + [] + _ : remaining -> + components : slowComponentSuffixes remaining + +slowCanonicalPath :: FilePath -> SlowCanonicalPath +slowCanonicalPath rawPath = + case rawPath of + firstSeparator : secondSeparator : remaining + | slowPathSeparator firstSeparator, + slowPathSeparator secondSeparator -> + case slowSplitPathComponents remaining of + server : share : components -> + SlowCanonicalPath + (SlowUncRootAnchor server share) + (slowNormaliseComponents True components) + components -> + SlowCanonicalPath + SlowPosixRootAnchor + (slowNormaliseComponents True components) + driveLetter : ':' : remaining + | isAlpha driveLetter -> + SlowCanonicalPath + (SlowDriveRootAnchor (toUpper driveLetter)) + (slowNormaliseComponents True (slowSplitPathComponents remaining)) + firstSeparator : remaining + | slowPathSeparator firstSeparator -> + SlowCanonicalPath + SlowPosixRootAnchor + (slowNormaliseComponents True (slowSplitPathComponents remaining)) + _ -> + SlowCanonicalPath + SlowRelativeAnchor + (slowNormaliseComponents False (slowSplitPathComponents rawPath)) + +slowSplitPathComponents :: FilePath -> [FilePath] +slowSplitPathComponents pathValue = + case dropWhile slowPathSeparator pathValue of + [] -> + [] + remaining -> + let (component, next) = break slowPathSeparator remaining + in component : slowSplitPathComponents next + +slowNormaliseComponents :: Bool -> [FilePath] -> [FilePath] +slowNormaliseComponents rooted = + reverse . foldl' normaliseComponent [] + where + normaliseComponent reversedComponents component + | component == "." || null component = + reversedComponents + | component == ".." = + case reversedComponents of + previous : remaining + | previous /= ".." -> + remaining + _ + | rooted -> + reversedComponents + | otherwise -> + ".." : reversedComponents + | otherwise = + component : reversedComponents + +slowRenderCanonicalPath :: SlowCanonicalPath -> FilePath +slowRenderCanonicalPath pathValue = + let componentText = intercalate "/" (slowPathComponents pathValue) + in case slowPathAnchor pathValue of + SlowRelativeAnchor -> + componentText + SlowPosixRootAnchor -> + "/" <> componentText + SlowDriveRootAnchor driveLetter -> + driveLetter : ':' : '/' : componentText + SlowUncRootAnchor server share -> + "//" <> server <> "/" <> share + <> if null componentText + then "" + else "/" <> componentText + +slowPathSeparator :: Char -> Bool +slowPathSeparator character = + character == '/' || character == '\\' + +oracleFixtureSource :: String +oracleFixtureSource = + unlines + [ "module OracleFixture where", + "composed = (.) id id", + "mapped xs = map id xs", + "mappedMaybe = fmap not (Just True)", + "shown = show (Just True)" + ] + +shadowFixtureSource :: String +shadowFixtureSource = + unlines + [ "module ShadowFixture where", + "import Prelude hiding ((.))", + "(.) x = x", + "token = ()", + "shadow = (.) token" + ] + +acceptedOriginsFor :: String -> IO (Set.Set ResolvedOrigin) +acceptedOriginsFor occText = + either + (\failure -> assertFailure ("accepted-origin fixture failed to parse: " <> show failure)) + (pure . Set.fromList) + ( traverse + (\(unitText, moduleText) -> mkResolvedOrigin unitText moduleText occText) + [ ("base", "GHC.Base"), + ("base", "GHC.Internal.Base"), + ("ghc-internal", "GHC.Internal.Base") + ] + ) + +compileAndReadOracle :: String -> String -> IO ModuleNameOracle +compileAndReadOracle moduleName sourceText = + hieArtifactOracle <$> compileAndReadArtifact moduleName sourceText + +compileAndReadArtifact :: String -> String -> IO HieOracleArtifact +compileAndReadArtifact moduleName sourceText = + withFreshTestDirectory ("oracle-" <> moduleName) $ \root -> do + let sourceDirectory = root "src" + hieDirectory = root "hie" + sourcePath = sourceDirectory moduleName <> ".hs" + createDirectoryIfMissing True sourceDirectory + createDirectoryIfMissing True hieDirectory + writeFile sourcePath sourceText + (exitCode, _stdoutText, stderrText) <- + readProcessWithExitCode + "ghc" + [ "-fno-code", + "-fforce-recomp", + "-fwrite-ide-info", + "-hiedir", + hieDirectory, + sourcePath + ] + "" + case exitCode of + ExitSuccess -> do + (errors, oracleIndex) <- indexHieRoots [hieDirectory] + let lookupResult = + lookupModuleOracle + oracleIndex + OracleQuery + { oqGivenPath = normalise sourcePath, + oqAbsolutePath = Just (normalise sourcePath), + oqSourceRoots = [sourceDirectory] + } + case (errors, lookupResult) of + ([], OracleFound _ artifact) -> + pure artifact + ([], _) -> + assertFailure ("oracle missing for " <> sourcePath <> ": " <> show lookupResult) + (hieErrors, _) -> + assertFailure ("hie read errors: " <> show hieErrors) + ExitFailure _ -> + assertFailure stderrText diff --git a/test/ghc-surface/Hie/TypeWordsSpec.hs b/test/ghc-surface/Hie/TypeWordsSpec.hs new file mode 100644 --- /dev/null +++ b/test/ghc-surface/Hie/TypeWordsSpec.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Hie.TypeWordsSpec (tests) where + +import Data.Array (Array, array) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Word (Word64) +import GHC.Iface.Ext.Types (HieArgs (..), HieType (..), HieTypeFlat, TypeIndex) +import GHC.Types.Name (Name, mkSystemName, nameUnique) +import GHC.Types.Name.Occurrence (mkTyVarOcc) +import GHC.Types.Unique (getKey, mkUnique) +import Language.Haskell.Syntax.Specificity (data Specified) +import Moonlight.Pale.Ghc.Hie.TypeWords + ( TypeGraphObstruction (..), + TypeWireFailure (..), + TypeWord (..), + hieTypeIndexTypeWords, + hieTypeRootsTypeWords, + typeWords, + typeWordsList, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + +tests :: TestTree +tests = + testGroup + "pale.hie.typewords" + [ testCase "forall binder names are alpha-normalized" $ + assertEqual + "forall a. a -> a and forall b. b -> b encode identically" + (hieTypeIndexTypeWords (forallIdentityTable "a") forallRoot) + (hieTypeIndexTypeWords (forallIdentityTable "b") forallRoot), + testCase "free type variables keep their identity" $ + assertBool + "free a and free b encode differently" + (hieTypeIndexTypeWords (freeVariableTable "a") freeRoot /= hieTypeIndexTypeWords (freeVariableTable "b") freeRoot), + testCase "display-equivalent free variables retain exact Name identity" $ + assertBool + "equal occurrence spelling with different uniques remains distinct" + ( hieTypeIndexTypeWords (freeNameTable (testNameWithUnique "a" 1)) freeRoot + /= hieTypeIndexTypeWords (freeNameTable (testNameWithUnique "a" 2)) freeRoot + ), + testCase "shared DAG nodes are emitted once rather than recursively unfolded" $ + case hieTypeIndexTypeWords (sharedDagTable 30) 30 of + Left obstruction -> + assertFailure ("unexpected graph obstruction: " <> show obstruction) + Right wordsValue -> + assertBool + "a 31-node doubling DAG has a linear wire representation" + (length (typeWordsList wordsValue) < 1000), + testCase "diamond sharing emits the common child once" $ + case hieTypeIndexTypeWords diamondTable 3 of + Left obstruction -> + assertFailure ("unexpected graph obstruction: " <> show obstruction) + Right wordsValue -> + assertBool + "the diamond remains a four-definition graph" + (length (typeWordsList wordsValue) < 80), + testCase "a root set is compiled by one shared graph pass" $ + let compiledRoots = + hieTypeRootsTypeWords + (sharedDagTable 30) + (Set.fromList [29, 30]) + in assertBool + "both distinct observed roots are present and successful" + ( Map.size compiledRoots == 2 + && all (either (const False) (const True)) compiledRoots + ), + testCase "missing type indices are typed obstructions" $ + assertEqual + "the missing child is not encoded as a successful sentinel" + (Left (MissingTypeIndex 1)) + (hieTypeIndexTypeWords (array (0, 0) [(0, HCastTy 1)]) 0), + testCase "cyclic type indices are typed obstructions" $ + assertEqual + "the cycle is not encoded as a successful sentinel" + (Left (CyclicTypeIndex 0)) + (hieTypeIndexTypeWords (array (0, 0) [(0, HCastTy 0)]) 0), + testCase "shared bound variables cannot escape their forall scope" $ + let binderName = testName "a" + in assertEqual + "the shared variable node is not silently reclassified as free" + (Left (EscapedBoundTypeVariable 1 (getKey (nameUnique binderName)))) + (hieTypeIndexTypeWords (escapedBinderTable binderName) 3), + testCase "independent roots retain independent binder-scope evidence" $ + let binderName = testName "a" + compiledRoots = + hieTypeRootsTypeWords + (independentBinderRootsTable binderName) + (Set.fromList [1, 2]) + in assertBool + "a shared flat variable may be free in one root and bound in another" + ( Map.size compiledRoots == 2 + && all (either (const False) (const True)) compiledRoots + ), + testCase "an earlier root memo cannot mask an intra-root binder escape" $ + let binderName = testName "a" + compiledRoots = + hieTypeRootsTypeWords + (escapedBinderTable binderName) + (Set.fromList [1, 3]) + in assertEqual + "the second root revalidates the memoized variable in its own scope" + (Just (Left (EscapedBoundTypeVariable 1 (getKey (nameUnique binderName))))) + (Map.lookup 3 compiledRoots), + testCase "memoized composites replay descendant binder evidence" $ + let binderName = testName "a" + compiledRoots = + hieTypeRootsTypeWords + (compositeEscapedBinderTable binderName) + (Set.fromList [2, 4]) + in assertEqual + "the cached cast cannot hide its free variable beneath the forall root" + (Just (Left (EscapedBoundTypeVariable 1 (getKey (nameUnique binderName))))) + (Map.lookup 4 compiledRoots), + testCase "variable-rich doubling preserves exact free-variable identity" $ + case + ( hieTypeIndexTypeWords + (variableRichDoublingTable (testNameWithUnique "a" 1) (testNameWithUnique "b" 2)) + 5, + hieTypeIndexTypeWords + (variableRichDoublingTable (testNameWithUnique "a" 1) (testNameWithUnique "b" 3)) + 5 + ) + of + (Right originalWords, Right changedWords) -> + assertBool + "hash-consed repeated sections retain every free Name identity" + (originalWords /= changedWords) + (originalResult, changedResult) -> + assertFailure + ( "unexpected variable-rich graph obstruction: " + <> show originalResult + <> " / " + <> show changedResult + ), + testCase "the public word constructor rejects unbounded wire values" $ + assertEqual + "Natural-to-Word64 narrowing is checked" + (Left (TypeNaturalExceedsWord64 (TypeArgumentCount (fromIntegral (maxBound :: Word64) + 1)))) + (typeWords [TypeArgumentCount (fromIntegral (maxBound :: Word64) + 1)]) + ] + +forallRoot :: TypeIndex +forallRoot = + 4 + +freeRoot :: TypeIndex +freeRoot = + 0 + +forallIdentityTable :: String -> Array TypeIndex HieTypeFlat +forallIdentityTable nameText = + let binderName = testName nameText + in array + (0, 4) + [ (0, HCoercionTy), + (1, HTyVarTy binderName), + (2, HCoercionTy), + (3, HFunTy 2 1 1), + (4, HForAllTy ((binderName, 0), Specified) 3) + ] + +freeVariableTable :: String -> Array TypeIndex HieTypeFlat +freeVariableTable nameText = + freeNameTable (testName nameText) + +freeNameTable :: Name -> Array TypeIndex HieTypeFlat +freeNameTable nameValue = + array (0, 0) [(0, HTyVarTy nameValue)] + +escapedBinderTable :: Name -> Array TypeIndex HieTypeFlat +escapedBinderTable binderName = + array + (0, 3) + [ (0, HCoercionTy), + (1, HTyVarTy binderName), + (2, HForAllTy ((binderName, 0), Specified) 1), + (3, HAppTy 2 (HieArgs [(True, 1)])) + ] + +independentBinderRootsTable :: Name -> Array TypeIndex HieTypeFlat +independentBinderRootsTable binderName = + array + (0, 2) + [ (0, HCoercionTy), + (1, HTyVarTy binderName), + (2, HForAllTy ((binderName, 0), Specified) 1) + ] + +compositeEscapedBinderTable :: Name -> Array TypeIndex HieTypeFlat +compositeEscapedBinderTable binderName = + array + (0, 4) + [ (0, HCoercionTy), + (1, HTyVarTy binderName), + (2, HCastTy 1), + (3, HForAllTy ((binderName, 0), Specified) 1), + (4, HAppTy 3 (HieArgs [(True, 2)])) + ] + +variableRichDoublingTable :: + Name -> + Name -> + Array TypeIndex HieTypeFlat +variableRichDoublingTable firstName secondName = + array + (0, 5) + [ (0, HTyVarTy firstName), + (1, HTyVarTy secondName), + (2, HAppTy 0 (HieArgs [(True, 1)])), + (3, HAppTy 2 (HieArgs [(True, 2)])), + (4, HAppTy 3 (HieArgs [(True, 3)])), + (5, HAppTy 4 (HieArgs [(True, 4)])) + ] + +sharedDagTable :: Int -> Array TypeIndex HieTypeFlat +sharedDagTable depth = + array + (0, depth) + ( (0, HCoercionTy) + : fmap + (\typeIndex -> (typeIndex, HAppTy (typeIndex - 1) (HieArgs [(True, typeIndex - 1)]))) + [1 .. depth] + ) + +diamondTable :: Array TypeIndex HieTypeFlat +diamondTable = + array + (0, 3) + [ (0, HCoercionTy), + (1, HCastTy 0), + (2, HAppTy 1 (HieArgs [(True, 0)])), + (3, HAppTy 2 (HieArgs [(True, 1)])) + ] + +testName :: String -> Name +testName nameText = + mkSystemName (mkUnique 't' (fromIntegral (sum (fmap fromEnum nameText)))) (mkTyVarOcc nameText) + +testNameWithUnique :: String -> Word64 -> Name +testNameWithUnique nameText uniqueValue = + mkSystemName (mkUnique 'u' uniqueValue) (mkTyVarOcc nameText) diff --git a/test/ghc-surface/Main.hs b/test/ghc-surface/Main.hs new file mode 100644 --- /dev/null +++ b/test/ghc-surface/Main.hs @@ -0,0 +1,24 @@ +module Main + ( main, + ) +where + +import Expr.RenderRoundTripSpec qualified as RenderRoundTripSpec +import Expr.SourceCoordinatesSpec qualified as SourceCoordinatesSpec +import Hie.OracleSpec qualified as OracleSpec +import ModuleSurfaceSpec qualified as ModuleSurfaceSpec +import Hie.TypeWordsSpec qualified as TypeWordsSpec +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain + ( testGroup + "pale-ghc-surface" + [ OracleSpec.tests, + TypeWordsSpec.tests, + ModuleSurfaceSpec.tests, + RenderRoundTripSpec.tests, + SourceCoordinatesSpec.tests + ] + ) diff --git a/test/ghc-surface/ModuleSurfaceSpec.hs b/test/ghc-surface/ModuleSurfaceSpec.hs new file mode 100644 --- /dev/null +++ b/test/ghc-surface/ModuleSurfaceSpec.hs @@ -0,0 +1,108 @@ +module ModuleSurfaceSpec + ( tests, + ) +where + +import Data.Bifunctor (first) +import Moonlight.Pale.Ghc.ModuleSurface + ( ExportChildSpec (..), + ExportItem (..), + ExportSpec (..), + ModuleSurface (..), + moduleSurfaceFromGhcPs, + parseHsModule, + renderGhcParseFailure, + unParsedModuleName, + unParsedName, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "pale.module-surface" + [ testCase "GHC2024 keeps pattern available as a type-variable name" $ + assertParses + "PatternTypeVariable.hs" + [ "{-# LANGUAGE GHC2024 #-}", + "module PatternTypeVariable where", + "", + "foo :: host pattern var -> ()", + "foo _ = ()" + ], + testCase "PatternSynonyms is enabled only when requested by LANGUAGE pragma" $ + assertParses + "PatternSynonymFixture.hs" + [ "{-# LANGUAGE PatternSynonyms #-}", + "module PatternSynonymFixture where", + "", + "pattern Unit = ()", + "value = Unit" + ], + testCase "multiline LANGUAGE pragmas are parsed by GHC's header parser" $ + assertParses + "MultilinePatternSynonymFixture.hs" + [ "{-# LANGUAGE", + " PatternSynonyms", + " #-}", + "module MultilinePatternSynonymFixture where", + "pattern Unit = ()" + ], + testCase "OPTIONS_GHC extension flags are parsed by GHC's header parser" $ + assertParses + "OptionsPatternSynonymFixture.hs" + [ "{-# OPTIONS_GHC -XPatternSynonyms #-}", + "module OptionsPatternSynonymFixture where", + "pattern Unit = ()" + ], + testCase "a missing export list remains implicit rather than becoming empty" $ do + moduleSurface <- + parseSurface + "Implicit.hs" + ["module Implicit where", "value = ()"] + surfaceExports moduleSurface @?= ImplicitExports, + testCase "explicit exports preserve namespace, children, and module re-exports" $ do + moduleSurface <- + parseSurface + "Explicit.hs" + [ "{-# LANGUAGE ExplicitNamespaces #-}", + "{-# LANGUAGE PatternSynonyms #-}", + "module Explicit (value, Type(..), pattern Unit, module Data.List) where", + "import Data.List", + "data Type = Constructor", + "pattern Unit = ()", + "value = ()" + ] + case surfaceExports moduleSurface of + ExplicitExports + [ ExportValue valueName, + ExportType typeName AllExportedChildren, + ExportPattern patternName, + ExportModule moduleName + ] -> do + unParsedName valueName @?= "value" + unParsedName typeName @?= "Type" + unParsedName patternName @?= "Unit" + unParsedModuleName moduleName @?= "Data.List" + otherExports -> + assertFailure ("unexpected explicit export structure: " <> show otherExports) + ] + +assertParses :: FilePath -> [String] -> IO () +assertParses sourcePath sourceLines = + case parseHsModule sourcePath (unlines sourceLines) of + Right _ -> + pure () + Left parserError -> + assertFailure + ("expected parser success for " <> sourcePath <> ":\n" <> renderGhcParseFailure parserError) + +parseSurface :: FilePath -> [String] -> IO ModuleSurface +parseSurface sourcePath sourceLines = + case first renderGhcParseFailure (parseHsModule sourcePath (unlines sourceLines)) + >>= first show . moduleSurfaceFromGhcPs of + Right moduleSurface -> + pure moduleSurface + Left surfaceError -> + assertFailure ("expected module-surface success for " <> sourcePath <> ":\n" <> surfaceError) diff --git a/test/import-discipline/DisciplineSpec.hs b/test/import-discipline/DisciplineSpec.hs new file mode 100644 --- /dev/null +++ b/test/import-discipline/DisciplineSpec.hs @@ -0,0 +1,94 @@ +module DisciplineSpec + ( tests, + ) +where + +import Control.Exception (SomeException, displayException, try) +import Data.List (isInfixOf) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Moonlight.Pale.Test.ImportDiscipline (SheafManifest (..), assertSheafDiscipline) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase) + +tests :: TestTree +tests = + testGroup + "Moonlight.Pale.Test.ImportDiscipline" + [ testCase "accepts lawful sheaf layering" lawfulLayeringIsClean, + testCase "rejects forbidden local import edge" violatingLayeringNamesForbiddenEdge + ] + +lawfulLayeringIsClean :: Assertion +lawfulLayeringIsClean = + assertSheafDiscipline packageMarker testSurfaceDirectory lawfulManifest + +violatingLayeringNamesForbiddenEdge :: Assertion +violatingLayeringNamesForbiddenEdge = + runDiscipline violatingManifest + >>= \disciplineResult -> + case disciplineResult of + Right () -> + assertFailure "expected sheaf import discipline to reject the forbidden local import edge" + Left exception -> + assertViolationNamesForbiddenEdge (displayException exception) + +assertViolationNamesForbiddenEdge :: String -> Assertion +assertViolationNamesForbiddenEdge failureMessage = + assertBool + "expected violation to name the forbidden Discipline -> Registry import edge" + (sourceModuleName `isInfixOf` failureMessage && targetModuleName `isInfixOf` failureMessage) + +runDiscipline :: SheafManifest -> IO (Either SomeException ()) +runDiscipline = + try . assertSheafDiscipline packageMarker testSurfaceDirectory + +lawfulManifest :: SheafManifest +lawfulManifest = + SheafManifest + { sheafModulePrefix = modulePrefix, + sheafAllowedImports = lawfulAllowedImports + } + +violatingManifest :: SheafManifest +violatingManifest = + SheafManifest + { sheafModulePrefix = modulePrefix, + sheafAllowedImports = violatingAllowedImports + } + +lawfulAllowedImports :: Map String (Set String) +lawfulAllowedImports = + Map.fromList + [ (sourceModuleName, Set.singleton targetModuleName), + (targetModuleName, Set.empty) + ] + +violatingAllowedImports :: Map String (Set String) +violatingAllowedImports = + Map.fromList + [ (sourceModuleName, Set.empty), + (targetModuleName, Set.empty) + ] + +packageMarker :: FilePath +packageMarker = + "moonlight-pale.cabal" + +testSurfaceDirectory :: FilePath +testSurfaceDirectory = + "src-test-surface" + +modulePrefix :: String +modulePrefix = + "Moonlight.Pale.Test.ImportDiscipline" + +sourceModuleName :: String +sourceModuleName = + "Moonlight.Pale.Test.ImportDiscipline" + +targetModuleName :: String +targetModuleName = + "Moonlight.Pale.Test.ImportDiscipline.Registry" diff --git a/test/import-discipline/Main.hs b/test/import-discipline/Main.hs new file mode 100644 --- /dev/null +++ b/test/import-discipline/Main.hs @@ -0,0 +1,12 @@ +module Main + ( main, + ) +where + +import DisciplineSpec qualified as DisciplineSpec +import RegistrySpec qualified as RegistrySpec +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain (testGroup "pale-test-surface" [DisciplineSpec.tests, RegistrySpec.tests]) diff --git a/test/import-discipline/RegistrySpec.hs b/test/import-discipline/RegistrySpec.hs new file mode 100644 --- /dev/null +++ b/test/import-discipline/RegistrySpec.hs @@ -0,0 +1,108 @@ +module RegistrySpec + ( tests, + ) +where + +import Data.List (isInfixOf) +import Data.Set qualified as Set +import Moonlight.Pale.Test.ImportDiscipline.Registry + ( CabalComponentSelector (..), + cabalComponentExposedModules, + cabalComponentOtherModules, + cabalComponentSourceDirectories, + cabalLibraryComponents, + parseCabalPackageMetadata, + renderCabalMetadataObstruction, + selectCabalComponentMetadata, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "typed Cabal registry" + [ testCase "projects main, named, and conditional component metadata" projectsComponentMetadata, + testCase "reports malformed Cabal as a typed obstruction" reportsMalformedCabal, + testCase "reports an absent component as a typed obstruction" reportsAbsentComponent + ] + +projectsComponentMetadata :: Assertion +projectsComponentMetadata = + case parseCabalPackageMetadata fixturePackage of + Left metadataObstruction -> + assertFailure (renderCabalMetadataObstruction "fixture.cabal" metadataObstruction) + Right packageMetadata -> do + fmap fst (cabalLibraryComponents packageMetadata) + @?= [CabalMainLibrary, CabalNamedLibrary "support"] + case + ( selectCabalComponentMetadata CabalMainLibrary packageMetadata, + selectCabalComponentMetadata (CabalNamedLibrary "support") packageMetadata, + selectCabalComponentMetadata (CabalTestSuite "unit") packageMetadata + ) + of + (Right mainLibrary, Right supportLibrary, Right unitTestSuite) -> do + cabalComponentSourceDirectories mainLibrary @?= Set.singleton "src" + cabalComponentExposedModules mainLibrary @?= Set.singleton "Surface.Main" + cabalComponentOtherModules mainLibrary + @?= Set.fromList ["Surface.Conditional", "Surface.Shared"] + cabalComponentSourceDirectories supportLibrary @?= Set.singleton "support" + cabalComponentExposedModules supportLibrary @?= Set.singleton "Surface.Support" + cabalComponentOtherModules unitTestSuite @?= Set.singleton "Surface.UnitSpec" + selectionResults -> + assertFailure ("expected all fixture components, observed " <> showSelectionResults selectionResults) + +reportsMalformedCabal :: Assertion +reportsMalformedCabal = + case parseCabalPackageMetadata "this is not a Cabal package" of + Right _ -> + assertFailure "expected malformed Cabal text to be rejected" + Left metadataObstruction -> + assertBool + "expected the parse obstruction to retain the Cabal source path" + ("fixture.cabal:" `isInfixOf` renderCabalMetadataObstruction "fixture.cabal" metadataObstruction) + +reportsAbsentComponent :: Assertion +reportsAbsentComponent = + case parseCabalPackageMetadata fixturePackage of + Left metadataObstruction -> + assertFailure (renderCabalMetadataObstruction "fixture.cabal" metadataObstruction) + Right packageMetadata -> + case selectCabalComponentMetadata (CabalNamedLibrary "absent") packageMetadata of + Right _ -> + assertFailure "expected an absent component to be rejected" + Left metadataObstruction -> + renderCabalMetadataObstruction "fixture.cabal" metadataObstruction + @?= "fixture.cabal: missing Cabal component library absent" + +showSelectionResults :: (Either obstruction value, Either obstruction value, Either obstruction value) -> String +showSelectionResults selectionResults = + case selectionResults of + (Left _, _, _) -> "main library obstruction" + (_, Left _, _) -> "support library obstruction" + (_, _, Left _) -> "unit test-suite obstruction" + (Right _, Right _, Right _) -> "all components present" + +fixturePackage :: String +fixturePackage = + unlines + [ "cabal-version: 3.8", + "name: pale-cabal-registry-fixture", + "version: 0.1.0.0", + "flag feature", + " default: True", + "library", + " hs-source-dirs: src", + " exposed-modules: Surface.Main", + " other-modules: Surface.Shared", + " if flag(feature)", + " other-modules: Surface.Conditional", + "library support", + " hs-source-dirs: support", + " exposed-modules: Surface.Support", + "test-suite unit", + " type: exitcode-stdio-1.0", + " main-is: Main.hs", + " hs-source-dirs: test", + " other-modules: Surface.UnitSpec" + ] diff --git a/test/laws/AlgebraicSpec.hs b/test/laws/AlgebraicSpec.hs new file mode 100644 --- /dev/null +++ b/test/laws/AlgebraicSpec.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE GHC2024 #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wmissing-local-signatures #-} + +module AlgebraicSpec + ( tests, + ) +where + +import Moonlight.Core (AdditiveGroup (..), AdditiveMonoid (..), MultiplicativeMonoid (..), Ring, Semiring) +import Moonlight.Pale.Test.Laws.Algebraic + ( groupLeftInverse, + monoidAssociativity, + ringDistributivityLeft, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase) + +newtype Mod5 = Mod5 Int + deriving stock (Eq, Show) + +instance AdditiveMonoid Mod5 where + zero :: Mod5 + zero = Mod5 0 + + add :: Mod5 -> Mod5 -> Mod5 + add (Mod5 x) (Mod5 y) = normalizeMod5 (x + y) + +instance AdditiveGroup Mod5 where + neg :: Mod5 -> Mod5 + neg (Mod5 x) = normalizeMod5 (negate x) + +instance MultiplicativeMonoid Mod5 where + one :: Mod5 + one = Mod5 1 + + mul :: Mod5 -> Mod5 -> Mod5 + mul (Mod5 x) (Mod5 y) = normalizeMod5 (x * y) + +instance Semiring Mod5 + +instance Ring Mod5 + +tests :: TestTree +tests = + testGroup + "Moonlight.Pale.Test.Laws.Algebraic" + [ testCase "modular addition satisfies monoid associativity" $ + assertBool "expected Z/5Z addition to be associative" $ + allTernary (monoidAssociativity add) mod5Carrier, + testCase "modular addition satisfies group left inverse" $ + assertBool "expected Z/5Z addition to satisfy left inverse" $ + allUnary (groupLeftInverse add neg zero) mod5Carrier, + testCase "modular arithmetic satisfies left distributivity" $ + assertBool "expected Z/5Z multiplication to distribute over addition" $ + allTernary ringDistributivityLeft mod5Carrier, + testCase "associativity rejects a non-associative operation" $ + assertBool "expected subtraction modulo five to fail associativity" $ + not (allTernary (monoidAssociativity nonAssociativeOperation) mod5Carrier) + ] + +mod5Carrier :: [Mod5] +mod5Carrier = fmap Mod5 [0, 1, 2, 3, 4] + +normalizeMod5 :: Int -> Mod5 +normalizeMod5 value = Mod5 (value `mod` 5) + +nonAssociativeOperation :: Mod5 -> Mod5 -> Mod5 +nonAssociativeOperation (Mod5 x) (Mod5 y) = normalizeMod5 (x - y) + +allUnary :: (a -> Bool) -> [a] -> Bool +allUnary predicate values = all predicate values + +allTernary :: (a -> a -> a -> Bool) -> [a] -> Bool +allTernary predicate values = all (applyTernary predicate) ((,,) <$> values <*> values <*> values) + +applyTernary :: (a -> a -> a -> Bool) -> (a, a, a) -> Bool +applyTernary predicate (x, y, z) = predicate x y z diff --git a/test/laws/LatticeSpec.hs b/test/laws/LatticeSpec.hs new file mode 100644 --- /dev/null +++ b/test/laws/LatticeSpec.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE GHC2024 #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wmissing-local-signatures #-} + +module LatticeSpec + ( tests, + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Moonlight.Pale.Test.Laws.Lattice + ( FiniteLattice, + FiniteLatticeError (..), + LatticeBounds (..), + compileFiniteLattice, + finiteLatticeJoin, + finiteLatticeLaws, + finiteLatticeMeet, + ) +import Moonlight.Pale.Test.Laws.Suite (lawGroup, renderLawSuite) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertEqual, assertFailure, testCase) +import Test.Tasty.QuickCheck + ( Gen, + Property, + chooseInt, + conjoin, + counterexample, + forAll, + testProperty, + vectorOf, + (===), + ) + +data Diamond + = DiamondBottom + | DiamondLeft + | DiamondRight + | DiamondTop + deriving stock (Eq, Ord, Show) + +data OpenValue + = OpenBottom + | OpenTop + | EscapedValue + deriving stock (Eq, Ord, Show) + +data TableValue + = TableValue !Int + | MissingTableEntry !Int !Int + deriving stock (Eq, Ord, Show) + +data ClosedOperationTables = ClosedOperationTables + { closedTableUniverse :: !(NonEmpty TableValue), + closedJoinTable :: !(Map (TableValue, TableValue) TableValue), + closedMeetTable :: !(Map (TableValue, TableValue) TableValue) + } + deriving stock (Show) + +tests :: TestTree +tests = + testGroup + "Moonlight.Pale.Test.Laws.Lattice" + [ renderFiniteLattice "Bool bounded lattice" boolLattice, + renderFiniteLattice "diamond bounded lattice" diamondLattice, + testCase "bounds outside the universe are typed construction errors" $ + assertLatticeErrors + "top is absent" + (TopOutsideUniverse True :| []) + invalidBoundedLattice, + testCase "duplicate universe values retain both positions" $ + assertLatticeErrors + "the second False duplicates the first" + (DuplicateUniverseElement False 0 2 :| []) + duplicateUniverseLattice, + testCase "join closure failures name operands and escaped results" $ + case closureFailureLattice of + Left errors -> + assertEqual + "every ordered pair was evaluated once and rejected" + ( fmap + (\(leftValue, rightValue) -> + JoinOutsideUniverse leftValue rightValue EscapedValue + ) + openPairs + ) + (toList errors) + Right _ -> assertFailure "expected escaped join results to reject compilation", + testCase "dense lookup returns the original operation results" $ + case diamondLattice of + Left errors -> assertFailure ("expected a compiled diamond: " <> show errors) + Right lattice -> do + assertEqual + "join table" + (Right DiamondTop) + (finiteLatticeJoin lattice DiamondLeft DiamondRight) + assertEqual + "meet table" + (Right DiamondBottom) + (finiteLatticeMeet lattice DiamondLeft DiamondRight), + testProperty + "compiled dense tables agree with a simple list oracle" + finiteLatticeDifferentialProperty + ] + +boolLattice :: Either (NonEmpty (FiniteLatticeError Bool)) (FiniteLattice Bool) +boolLattice = + compileFiniteLattice + "Bool" + (False :| [True]) + (||) + (&&) + (Just (LatticeBounds False True)) + +diamondLattice :: Either (NonEmpty (FiniteLatticeError Diamond)) (FiniteLattice Diamond) +diamondLattice = + compileFiniteLattice + "diamond" + diamondUniverse + diamondJoin + diamondMeet + (Just (LatticeBounds DiamondBottom DiamondTop)) + +invalidBoundedLattice :: Either (NonEmpty (FiniteLatticeError Bool)) (FiniteLattice Bool) +invalidBoundedLattice = + compileFiniteLattice + "invalid Bool" + (False :| []) + (||) + (&&) + (Just (LatticeBounds False True)) + +duplicateUniverseLattice :: Either (NonEmpty (FiniteLatticeError Bool)) (FiniteLattice Bool) +duplicateUniverseLattice = + compileFiniteLattice + "duplicate Bool" + (False :| [True, False]) + (||) + (&&) + Nothing + +closureFailureLattice :: Either (NonEmpty (FiniteLatticeError OpenValue)) (FiniteLattice OpenValue) +closureFailureLattice = + compileFiniteLattice + "open operation" + openUniverse + (\_ _ -> EscapedValue) + openMeet + Nothing + +openUniverse :: NonEmpty OpenValue +openUniverse = OpenBottom :| [OpenTop] + +openPairs :: [(OpenValue, OpenValue)] +openPairs = + (,) <$> toList openUniverse <*> toList openUniverse + +openMeet :: OpenValue -> OpenValue -> OpenValue +openMeet leftValue rightValue + | leftValue == OpenBottom = OpenBottom + | rightValue == OpenBottom = OpenBottom + | otherwise = OpenTop + +diamondUniverse :: NonEmpty Diamond +diamondUniverse = DiamondBottom :| [DiamondLeft, DiamondRight, DiamondTop] + +diamondJoin :: Diamond -> Diamond -> Diamond +diamondJoin leftValue rightValue + | diamondLeq leftValue rightValue = rightValue + | diamondLeq rightValue leftValue = leftValue + | otherwise = DiamondTop + +diamondMeet :: Diamond -> Diamond -> Diamond +diamondMeet leftValue rightValue + | diamondLeq leftValue rightValue = leftValue + | diamondLeq rightValue leftValue = rightValue + | otherwise = DiamondBottom + +diamondLeq :: Diamond -> Diamond -> Bool +diamondLeq leftValue rightValue = + leftValue == rightValue || leftValue == DiamondBottom || rightValue == DiamondTop + +renderFiniteLattice :: + Show a => + String -> + Either (NonEmpty (FiniteLatticeError a)) (FiniteLattice a) -> + TestTree +renderFiniteLattice label latticeResult = + case latticeResult of + Left errors -> + testCase (label <> " compiles") $ + assertFailure ("expected valid finite lattice: " <> show errors) + Right lattice -> + renderLawSuite (lawGroup label (finiteLatticeLaws lattice)) + +assertLatticeErrors :: + (Eq a, Show a) => + String -> + NonEmpty (FiniteLatticeError a) -> + Either (NonEmpty (FiniteLatticeError a)) (FiniteLattice a) -> + IO () +assertLatticeErrors label expectedErrors latticeResult = + case latticeResult of + Left actualErrors -> assertEqual label expectedErrors actualErrors + Right _ -> assertFailure (label <> ": expected finite lattice compilation to fail") + +finiteLatticeDifferentialProperty :: Property +finiteLatticeDifferentialProperty = + forAll closedOperationTablesGenerator $ \tables -> + case + compileFiniteLattice + "generated" + (closedTableUniverse tables) + (operationFromTable (closedJoinTable tables)) + (operationFromTable (closedMeetTable tables)) + Nothing + of + Left errors -> + counterexample ("closed operation table was rejected: " <> show errors) False + Right lattice -> + conjoin $ + fmap + (\(leftValue, rightValue) -> + conjoin + [ finiteLatticeJoin lattice leftValue rightValue + === Right (operationFromTable (closedJoinTable tables) leftValue rightValue), + finiteLatticeMeet lattice leftValue rightValue + === Right (operationFromTable (closedMeetTable tables) leftValue rightValue) + ] + ) + (simplePairs (toList (closedTableUniverse tables))) + +closedOperationTablesGenerator :: Gen ClosedOperationTables +closedOperationTablesGenerator = do + cardinality <- chooseInt (1, 4) + let universe = TableValue 0 :| fmap TableValue [1 .. cardinality - 1] + pairs = simplePairs (toList universe) + joinResults <- vectorOf (cardinality * cardinality) (TableValue <$> chooseInt (0, cardinality - 1)) + meetResults <- vectorOf (cardinality * cardinality) (TableValue <$> chooseInt (0, cardinality - 1)) + pure + ClosedOperationTables + { closedTableUniverse = universe, + closedJoinTable = Map.fromList (zip pairs joinResults), + closedMeetTable = Map.fromList (zip pairs meetResults) + } + +simplePairs :: [a] -> [(a, a)] +simplePairs values = + (,) <$> values <*> values + +operationFromTable :: + Map (TableValue, TableValue) TableValue -> + TableValue -> + TableValue -> + TableValue +operationFromTable table leftValue rightValue = + case (leftValue, rightValue) of + (TableValue leftIndex, TableValue rightIndex) -> + Map.findWithDefault + (MissingTableEntry leftIndex rightIndex) + (leftValue, rightValue) + table + (MissingTableEntry leftIndex rightIndex, _) -> + MissingTableEntry leftIndex rightIndex + (_, MissingTableEntry leftIndex rightIndex) -> + MissingTableEntry leftIndex rightIndex + +toList :: NonEmpty a -> [a] +toList (firstValue :| remainingValues) = + firstValue : remainingValues diff --git a/test/laws/Main.hs b/test/laws/Main.hs new file mode 100644 --- /dev/null +++ b/test/laws/Main.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE GHC2024 #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wmissing-local-signatures #-} + +module Main + ( main, + ) +where + +import AlgebraicSpec qualified as AlgebraicSpec +import LatticeSpec qualified as LatticeSpec +import RestrictionSpec qualified as RestrictionSpec +import SuiteSpec qualified as SuiteSpec +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain + ( testGroup + "pale-test-laws" + [ AlgebraicSpec.tests, + LatticeSpec.tests, + RestrictionSpec.tests, + SuiteSpec.tests + ] + ) diff --git a/test/laws/RestrictionSpec.hs b/test/laws/RestrictionSpec.hs new file mode 100644 --- /dev/null +++ b/test/laws/RestrictionSpec.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE GHC2024 #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wmissing-local-signatures #-} + +module RestrictionSpec + ( tests, + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Moonlight.Pale.Test.Laws.Restriction + ( FiniteRestrictionError (..), + FiniteRestrictionLaw, + compileFiniteRestrictionLaw, + finiteRestrictionLaws, + ) +import Moonlight.Pale.Test.Laws.Suite (lawGroup, renderLawSuite) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) + +data ChainCell + = ChainBottom + | ChainMiddle + | ChainTop + deriving stock (Eq, Ord, Show) + +data OwnedSection + = OwnedSection !ChainCell !Int + | RestrictionSourceMismatch !ChainCell !ChainCell !Int + deriving stock (Eq, Show) + +tests :: TestTree +tests = + testGroup + "Moonlight.Pale.Test.Laws.Restriction" + [ renderFiniteRestriction "chain restriction suite" chainRestriction, + testCase "source and target identities apply identity at the typed object" $ do + let sourceSection = OwnedSection ChainBottom 7 + direct = restrictOwnedSection ChainBottom ChainMiddle sourceSection + reversedSourceIdentity = + restrictOwnedSection + ChainBottom + ChainBottom + (restrictOwnedSection ChainBottom ChainMiddle sourceSection) + reversedTargetIdentity = + restrictOwnedSection + ChainBottom + ChainMiddle + (restrictOwnedSection ChainMiddle ChainMiddle sourceSection) + assertEqual + "source identity" + direct + ( restrictOwnedSection + ChainBottom + ChainMiddle + (restrictOwnedSection ChainBottom ChainBottom sourceSection) + ) + assertEqual + "target identity" + direct + ( restrictOwnedSection + ChainMiddle + ChainMiddle + (restrictOwnedSection ChainBottom ChainMiddle sourceSection) + ) + assertBool + "the former source equation applies the identity to the wrong fiber" + (reversedSourceIdentity /= direct) + assertBool + "the former target equation applies the identity before entering its fiber" + (reversedTargetIdentity /= direct), + testCase "duplicate cells retain both dense positions" $ + assertRestrictionErrors + "duplicate ChainBottom" + (DuplicateRestrictionCell ChainBottom 0 2 :| []) + duplicateCellRestriction, + testCase "sections outside the finite cell universe are rejected" $ + assertRestrictionErrors + "unknown source cell" + (SectionCellOutsideUniverse ChainTop :| []) + unknownSectionRestriction, + testCase "non-reflexive relations cannot compile" $ + assertRestrictionErrors + "both missing identities are reported" + ( RestrictionRelationNotReflexive ChainBottom + :| [RestrictionRelationNotReflexive ChainMiddle] + ) + nonReflexiveRestriction, + testCase "contradictory two-way order cannot compile" $ + assertRestrictionErrors + "antisymmetry rejects distinct mutually related cells" + (RestrictionRelationNotAntisymmetric ChainBottom ChainMiddle :| []) + contradictoryRestriction, + testCase "non-transitive relation cannot compile" $ + assertRestrictionErrors + "the missing bottom-to-top edge is typed" + (RestrictionRelationNotTransitive ChainBottom ChainMiddle :| []) + nonTransitiveRestriction + ] + +chainRestriction :: + Either + (NonEmpty (FiniteRestrictionError ChainCell)) + (FiniteRestrictionLaw ChainCell OwnedSection) +chainRestriction = + compileFiniteRestrictionLaw + "chain" + chainCells + chainLeq + chainSections + restrictOwnedSection + +duplicateCellRestriction :: + Either + (NonEmpty (FiniteRestrictionError ChainCell)) + (FiniteRestrictionLaw ChainCell OwnedSection) +duplicateCellRestriction = + compileFiniteRestrictionLaw + "duplicate" + (ChainBottom :| [ChainMiddle, ChainBottom]) + chainLeq + [] + restrictOwnedSection + +unknownSectionRestriction :: + Either + (NonEmpty (FiniteRestrictionError ChainCell)) + (FiniteRestrictionLaw ChainCell OwnedSection) +unknownSectionRestriction = + compileFiniteRestrictionLaw + "unknown section" + (ChainBottom :| [ChainMiddle]) + chainLeq + [(ChainTop, OwnedSection ChainTop 0)] + restrictOwnedSection + +nonReflexiveRestriction :: + Either + (NonEmpty (FiniteRestrictionError ChainCell)) + (FiniteRestrictionLaw ChainCell OwnedSection) +nonReflexiveRestriction = + compileFiniteRestrictionLaw + "non-reflexive" + (ChainBottom :| [ChainMiddle]) + (\_ _ -> False) + [] + restrictOwnedSection + +contradictoryRestriction :: + Either + (NonEmpty (FiniteRestrictionError ChainCell)) + (FiniteRestrictionLaw ChainCell OwnedSection) +contradictoryRestriction = + compileFiniteRestrictionLaw + "contradictory" + (ChainBottom :| [ChainMiddle]) + (\_ _ -> True) + [] + restrictOwnedSection + +nonTransitiveRestriction :: + Either + (NonEmpty (FiniteRestrictionError ChainCell)) + (FiniteRestrictionLaw ChainCell OwnedSection) +nonTransitiveRestriction = + compileFiniteRestrictionLaw + "non-transitive" + chainCells + adjacentChainLeq + [] + restrictOwnedSection + +chainCells :: NonEmpty ChainCell +chainCells = ChainBottom :| [ChainMiddle, ChainTop] + +chainSections :: [(ChainCell, OwnedSection)] +chainSections = + fmap + (\cell -> (cell, OwnedSection cell (chainRank cell))) + (toList chainCells) + +restrictOwnedSection :: ChainCell -> ChainCell -> OwnedSection -> OwnedSection +restrictOwnedSection sourceCell targetCell section = + case section of + OwnedSection owner payload + | owner == sourceCell -> OwnedSection targetCell payload + | otherwise -> RestrictionSourceMismatch sourceCell owner payload + RestrictionSourceMismatch expectedSource actualSource payload -> + RestrictionSourceMismatch expectedSource actualSource payload + +chainLeq :: ChainCell -> ChainCell -> Bool +chainLeq leftCell rightCell = + chainRank leftCell <= chainRank rightCell + +adjacentChainLeq :: ChainCell -> ChainCell -> Bool +adjacentChainLeq leftCell rightCell = + leftCell == rightCell + || (leftCell == ChainBottom && rightCell == ChainMiddle) + || (leftCell == ChainMiddle && rightCell == ChainTop) + +chainRank :: ChainCell -> Int +chainRank cell = + case cell of + ChainBottom -> 0 + ChainMiddle -> 1 + ChainTop -> 2 + +renderFiniteRestriction :: + (Show cell, Show val, Eq val) => + String -> + Either (NonEmpty (FiniteRestrictionError cell)) (FiniteRestrictionLaw cell val) -> + TestTree +renderFiniteRestriction label restrictionResult = + case restrictionResult of + Left errors -> + testCase (label <> " compiles") $ + assertFailure ("expected valid finite restriction law: " <> show errors) + Right restrictionLaw -> + renderLawSuite (lawGroup label (finiteRestrictionLaws restrictionLaw)) + +assertRestrictionErrors :: + (Eq cell, Show cell) => + String -> + NonEmpty (FiniteRestrictionError cell) -> + Either + (NonEmpty (FiniteRestrictionError cell)) + (FiniteRestrictionLaw cell val) -> + IO () +assertRestrictionErrors label expectedErrors restrictionResult = + case restrictionResult of + Left actualErrors -> assertEqual label expectedErrors actualErrors + Right _ -> assertFailure (label <> ": expected finite restriction compilation to fail") + +toList :: NonEmpty a -> [a] +toList (firstValue :| remainingValues) = + firstValue : remainingValues diff --git a/test/laws/SuiteSpec.hs b/test/laws/SuiteSpec.hs new file mode 100644 --- /dev/null +++ b/test/laws/SuiteSpec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DerivingStrategies #-} + +module SuiteSpec + ( tests, + ) +where + +import Moonlight.Core (IsLawName (..)) +import Moonlight.Pale.Test.Laws.Suite + ( hUnitLaw, + lawGroup, + namedHedgehogLaw, + namedQuickCheckLaw, + renderLawSuite, + testTreeLaw, + ) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit ((@?=), testCase) + +data SuiteLawName + = QuickCheckIdentity + | HedgehogIdentity + deriving stock (Eq, Ord, Show) + +instance IsLawName SuiteLawName where + lawNameText lawName = + case lawName of + QuickCheckIdentity -> "quickcheck_identity" + HedgehogIdentity -> "hedgehog_identity" + +tests :: TestTree +tests = + renderLawSuite + ( lawGroup + "Moonlight.Pale.Test.Laws.Suite" + [ namedQuickCheckLaw QuickCheckIdentity (\value -> not (not value) == (value :: Bool)), + namedHedgehogLaw HedgehogIdentity (pure True) id, + hUnitLaw "hunit leaf" (True @?= True), + testTreeLaw (testCase "embedded test leaf" (True @?= True)), + lawGroup "nested group" [hUnitLaw "nested leaf" (True @?= True)] + ] + ) diff --git a/test/test-support/Assertions/AssertionSpec.hs b/test/test-support/Assertions/AssertionSpec.hs new file mode 100644 --- /dev/null +++ b/test/test-support/Assertions/AssertionSpec.hs @@ -0,0 +1,56 @@ +module Assertions.AssertionSpec + ( tests, + ) +where + +import Data.Set qualified as Set +import Moonlight.Pale.Test.Assertions + ( assertApproxEqual, + assertNonEmpty, + assertSubsetOf, + expectRight, + expectRightWithLabel, + expectSome, + withResult, + ) +import Moonlight.Pale.Test.Core (ToleranceObstruction (..), mkTolerance) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), assertBool, assertFailure, testCase) + +tests :: TestTree +tests = + testGroup + "Moonlight.Pale.Test.Assertions" + [ testCase "unwraps an unlabeled Right" $ + expectRight (Right "value" :: Either String String) >>= (@?= "value"), + testCase "unwraps a labeled Right" $ + expectRightWithLabel "fixture" (Right "value" :: Either String String) >>= (@?= "value"), + testCase "unwraps a labeled Just" $ + expectSome "fixture" (Just "value") >>= (@?= "value"), + testCase "continues an assertion with a Right value" $ + withResult (Right "value" :: Either String String) (@?= "value"), + testCase "accepts a non-empty list" $ + assertNonEmpty ["value"], + testCase "accepts a subset" $ + assertSubsetOf (Set.fromList [1, 2 :: Int]) (Set.fromList [1, 2, 3]), + testCase "zero tolerance accepts exact equality" $ + assertApproxEqual "exact" (mkTolerance 0 0) 1 1, + testCase "relative tolerance scales with magnitude" $ + assertApproxEqual "relative" (mkTolerance 0 0.1) 100 105, + testCase "equal infinities compare exactly" $ + assertApproxEqual "infinity" (mkTolerance 0 0) (1 / 0) (1 / 0), + testCase "non-finite tolerance is a typed obstruction" $ + case mkTolerance (0 / 0) 0 of + Left (ToleranceNotFinite absoluteLimit _) -> + assertBool "expected retained NaN evidence" (isNaN absoluteLimit) + other -> + assertFailure ("expected ToleranceNotFinite, got " <> show other), + testCase "negative tolerance is a typed obstruction" $ + mkTolerance (-1) 0 @?= Left (ToleranceNegative (-1) 0), + testCase "non-finite relative tolerance is a typed obstruction" $ + case mkTolerance 0 (1 / 0) of + Left (ToleranceNotFinite _ relativeLimit) -> + assertBool "expected retained infinity evidence" (isInfinite relativeLimit) + other -> + assertFailure ("expected ToleranceNotFinite, got " <> show other) + ] diff --git a/test/test-support/Main.hs b/test/test-support/Main.hs new file mode 100644 --- /dev/null +++ b/test/test-support/Main.hs @@ -0,0 +1,19 @@ +module Main + ( main, + ) +where + +import Assertions.AssertionSpec qualified as AssertionSpec +import Recursion.RecursionSpec qualified as RecursionSpec +import Resources.ResourceSpec qualified as ResourceSpec +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain $ + testGroup + "pale-test-support" + [ AssertionSpec.tests, + RecursionSpec.tests, + ResourceSpec.tests + ] diff --git a/test/test-support/Recursion/RecursionSpec.hs b/test/test-support/Recursion/RecursionSpec.hs new file mode 100644 --- /dev/null +++ b/test/test-support/Recursion/RecursionSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Recursion.RecursionSpec + ( tests, + ) +where + +import Hedgehog qualified as HH +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Moonlight.Pale.Test.Recursion + ( cataAfterAnaIdentity, + interpreterCoherence, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog qualified as TH +import Test.Tasty.HUnit ((@?=), testCase) +import Test.Tasty.QuickCheck qualified as QC + +newtype RecursionBound = RecursionBound + { recursionBoundValue :: Int + } + deriving stock (Eq, Show) + +data RecursionTrace = RecursionTrace + { recursionTraceConfiguredBound :: RecursionBound, + recursionTraceVisitedFrames :: [Int] + } + deriving stock (Eq, Show) + +data RecursionReport = RecursionReport + { recursionReportSteps :: Int, + recursionReportStoppedAtBound :: Bool + } + deriving stock (Eq, Show) + +tests :: TestTree +tests = + testGroup + "Moonlight.Pale.Test.Recursion" + [ testCase "cata-after-ana distinguishes coherent and incoherent inverses" $ do + cataAfterAnaIdentity boundedAna traceConfiguredBound configuredBound @?= True + cataAfterAnaIdentity boundedAna underreportedTraceBound configuredBound @?= False, + testCase "interpreter coherence distinguishes matching and mismatched reports" $ do + interpreterCoherence boundedAna boundedCata boundedHylo configuredBound @?= True + interpreterCoherence boundedAna mismatchedCata boundedHylo configuredBound @?= False, + QC.testProperty "QuickCheck: bounded recursion reports its configured limit" $ + QC.property boundedReportMatchesNonNegative, + TH.testProperty "Hedgehog: bounded recursion reports its configured limit" $ + HH.property (HH.forAll boundedGenerator >>= HH.assert . boundedReportMatchesBound) + ] + +configuredBound :: RecursionBound +configuredBound = + RecursionBound 4 + +boundedGenerator :: HH.Gen RecursionBound +boundedGenerator = + RecursionBound <$> Gen.int (Range.linear 0 16) + +boundedReportMatchesNonNegative :: QC.NonNegative Int -> Bool +boundedReportMatchesNonNegative rawBound = + boundedReportMatchesBound (smallRecursionBound rawBound) + +boundedReportMatchesBound :: RecursionBound -> Bool +boundedReportMatchesBound bound = + boundedHylo bound + == RecursionReport + { recursionReportSteps = recursionBoundValue bound, + recursionReportStoppedAtBound = True + } + +smallRecursionBound :: QC.NonNegative Int -> RecursionBound +smallRecursionBound (QC.NonNegative rawBound) = + RecursionBound (rawBound `mod` 17) + +boundedAna :: RecursionBound -> RecursionTrace +boundedAna bound = + RecursionTrace + { recursionTraceConfiguredBound = bound, + recursionTraceVisitedFrames = [0 .. recursionBoundValue bound - 1] + } + +boundedCata :: RecursionTrace -> RecursionReport +boundedCata trace = + RecursionReport + { recursionReportSteps = length (recursionTraceVisitedFrames trace), + recursionReportStoppedAtBound = length (recursionTraceVisitedFrames trace) == recursionBoundValue (recursionTraceConfiguredBound trace) + } + +boundedHylo :: RecursionBound -> RecursionReport +boundedHylo = + boundedCata . boundedAna + +traceConfiguredBound :: RecursionTrace -> RecursionBound +traceConfiguredBound = + recursionTraceConfiguredBound + +underreportedTraceBound :: RecursionTrace -> RecursionBound +underreportedTraceBound trace = + RecursionBound (recursionBoundValue (recursionTraceConfiguredBound trace) - 1) + +mismatchedCata :: RecursionTrace -> RecursionReport +mismatchedCata trace = + RecursionReport + { recursionReportSteps = recursionReportSteps (boundedCata trace) + 1, + recursionReportStoppedAtBound = False + } diff --git a/test/test-support/Resources/ResourceSpec.hs b/test/test-support/Resources/ResourceSpec.hs new file mode 100644 --- /dev/null +++ b/test/test-support/Resources/ResourceSpec.hs @@ -0,0 +1,37 @@ +module Resources.ResourceSpec + ( tests, + ) +where + +import Moonlight.Pale.Test.Resources + ( ResourcePathError (ResourcePathNotRelativeToRoot), + resolveCompilerFile, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertFailure, testCase) + +tests :: TestTree +tests = + testGroup + "Moonlight.Pale.Test.Resources" + [ testCase "rejects an absolute child path" $ + assertPathNotRelativeToRoot "/tmp/moonlight-pale-escape", + testCase "rejects a parent-relative child path" $ + assertPathNotRelativeToRoot "../moonlight-pale-escape" + ] + +assertPathNotRelativeToRoot :: FilePath -> Assertion +assertPathNotRelativeToRoot childPath = + resolveCompilerFile packageMarker childPath + >>= \resolution -> + case resolution of + Left ResourcePathNotRelativeToRoot {} -> + pure () + Left otherFailure -> + assertFailure ("expected ResourcePathNotRelativeToRoot, got " <> show otherFailure) + Right resolvedPath -> + assertFailure ("escaped resource unexpectedly resolved to " <> resolvedPath) + +packageMarker :: FilePath +packageMarker = + "foundation/moonlight-pale/moonlight-pale.cabal"