packages feed

moonlight-pale (empty) → 0.1.0.0

raw patch · 103 files changed

+23721/−0 lines, 103 filesdep +Cabal-syntaxdep +aesondep +array

Dependencies added: Cabal-syntax, aeson, array, base, bytestring, containers, deepseq, directory, filepath, ghc, ghc-boot-th, hedgehog, moonlight-core, moonlight-pale, mtl, prettyprinter, primitive, process, tasty, tasty-bench, tasty-hedgehog, tasty-hunit, tasty-quickcheck, temporary, text, transformers, vector

Files

+ CHANGELOG.md view
@@ -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`.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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).
+ bench/aggregate/Main.hs view
@@ -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
+ bench/diagnostic/DiagnosticBench.hs view
@@ -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+    }
+ bench/diagnostic/Main.hs view
@@ -0,0 +1,10 @@+module Main+  ( main,+  )+where++import DiagnosticBench (diagnosticBenchmarks)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main = defaultMain [diagnosticBenchmarks]
+ bench/ghc-surface/GhcSurfaceBench.hs view
@@ -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
+ bench/ghc-surface/HieBench.hs view
@@ -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)
+ bench/ghc-surface/Main.hs view
@@ -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
+ bench/laws/LawBench.hs view
@@ -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)
+ bench/laws/Main.hs view
@@ -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]
+ bench/receipts/Main.hs view
@@ -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+    }
+ bench/support/BenchSupport.hs view
@@ -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+  ]
+ moonlight-pale.cabal view
@@ -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
+ src-bench/Moonlight/Pale/Bench/Measure.hs view
@@ -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
+ src-diagnostic-ghc/Moonlight/Pale/TestSupport/CompileDiagnostics.hs view
@@ -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
+ src-diagnostic-ghc/Moonlight/Pale/TestSupport/CompileHieFixture.hs view
@@ -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 == '\''
+ src-diagnostic/Moonlight/Pale/Diagnostic/Aggregation/Algebra.hs view
@@ -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
+ src-diagnostic/Moonlight/Pale/Diagnostic/Aggregation/Propagation.hs view
@@ -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
+ src-diagnostic/Moonlight/Pale/Diagnostic/Core.hs view
@@ -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)
+ src-diagnostic/Moonlight/Pale/Diagnostic/Local/Propagation.hs view
@@ -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)
+ src-diagnostic/Moonlight/Pale/Diagnostic/Local/Replay.hs view
@@ -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)
+ src-diagnostic/Moonlight/Pale/Diagnostic/Local/Rewrite.hs view
@@ -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)
+ src-diagnostic/Moonlight/Pale/Diagnostic/Local/Saturation.hs view
@@ -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
+ src-diagnostic/Moonlight/Pale/Diagnostic/Summary/Structural.hs view
@@ -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)
+ src-diagnostic/Moonlight/Pale/Diagnostic/Topology/Boundary.hs view
@@ -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)
+ src-diagnostic/Moonlight/Pale/Diagnostic/Topology/Cohomology.hs view
@@ -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
+ src-diagnostic/Moonlight/Pale/Diagnostic/Topology/Homotopy.hs view
@@ -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)
+ src-diagnostic/Moonlight/Pale/Diagnostic/Views/Rewrite.hs view
@@ -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+    }
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Coalgebra.hs view
@@ -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)
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Declaration.hs view
@@ -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+      }
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Dependencies.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Expression.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/FreeScopes.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Metrics.hs view
@@ -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+      }
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Obstruction.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Pattern.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Projection.hs view
@@ -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)
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Row.hs view
@@ -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+        }
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/Source.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Convert/State.hs view
@@ -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)+                      }+                }+            )+    )
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Equivalence.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/NameRender.hs view
@@ -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)
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Opaque.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Parse.hs view
@@ -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 "<haskell-expression>" 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))
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Analysis.hs view
@@ -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+    )
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Annotation.hs view
@@ -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 _ ->+    []
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Binding.hs view
@@ -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 "| ") " = "
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Carrier.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Document.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Expression.hs view
@@ -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 "]")
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Literal.hs view
@@ -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 "" <> "\\&"
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Module.hs view
@@ -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"+    )
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Name.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Pattern.hs view
@@ -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 "..")
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Render/Refusal.hs view
@@ -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)
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Scope.hs view
@@ -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)
+ src-ghc-surface/Moonlight/Pale/Ghc/Expr/Syntax.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Hie/Oracle.hs view
@@ -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 == '.'
+ src-ghc-surface/Moonlight/Pale/Ghc/Hie/Read.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Hie/SourceKey.hs view
@@ -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 == '\\'
+ src-ghc-surface/Moonlight/Pale/Ghc/Hie/TypeWords.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/Hie/TypeWords/Internal.hs view
@@ -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
+ src-ghc-surface/Moonlight/Pale/Ghc/ModuleSurface.hs view
@@ -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 "<documentation-group>")+    IEDoc {} ->+      Left (InvalidExportedName "<documentation>")+    IEDocNamed {} ->+      Left (InvalidExportedName "<named-documentation>")++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+    }
+ src-test-laws/Moonlight/Pale/Test/Laws/Algebraic.hs view
@@ -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
+ src-test-laws/Moonlight/Pale/Test/Laws/Lattice.hs view
@@ -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
+ src-test-laws/Moonlight/Pale/Test/Laws/Restriction.hs view
@@ -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
+ src-test-laws/Moonlight/Pale/Test/Laws/Suite.hs view
@@ -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)
+ src-test-surface/Moonlight/Pale/Test/ImportDiscipline.hs view
@@ -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
+ src-test-surface/Moonlight/Pale/Test/ImportDiscipline/Registry.hs view
@@ -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)
+ src-test/Moonlight/Pale/Test/Assertions.hs view
@@ -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
+ src-test/Moonlight/Pale/Test/Core.hs view
@@ -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
+ src-test/Moonlight/Pale/Test/Recursion.hs view
@@ -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)
+ src-test/Moonlight/Pale/Test/Resources.hs view
@@ -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")
+ test/bench-measure/Main.hs view
@@ -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+    }
+ test/compile-diagnostics/CompileDiagnosticsSpec.hs view
@@ -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)
+ test/compile-diagnostics/Main.hs view
@@ -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])
+ test/compile-diagnostics/fixtures/Trivial.hs view
@@ -0,0 +1,4 @@+module Trivial where++trivial :: ()+trivial = ()
+ test/diagnostic/CohomologySpec.hs view
@@ -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+    }
+ test/diagnostic/Main.hs view
@@ -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])
+ test/diagnostic/OutcomeSpec.hs view
@@ -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)
+ test/diagnostic/RefinementSpec.hs view
@@ -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
+ test/diagnostic/WriterSpec.hs view
@@ -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"+    }
+ test/ghc-surface/Expr/RenderRoundTripSpec.hs view
@@ -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
+ test/ghc-surface/Expr/SourceCoordinatesSpec.hs view
@@ -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
+ test/ghc-surface/Hie/OracleSpec.hs view
@@ -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
+ test/ghc-surface/Hie/TypeWordsSpec.hs view
@@ -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)
+ test/ghc-surface/Main.hs view
@@ -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+        ]+    )
+ test/ghc-surface/ModuleSurfaceSpec.hs view
@@ -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)
+ test/import-discipline/DisciplineSpec.hs view
@@ -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"
+ test/import-discipline/Main.hs view
@@ -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])
+ test/import-discipline/RegistrySpec.hs view
@@ -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"+    ]
+ test/laws/AlgebraicSpec.hs view
@@ -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
+ test/laws/LatticeSpec.hs view
@@ -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
+ test/laws/Main.hs view
@@ -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+        ]+    )
+ test/laws/RestrictionSpec.hs view
@@ -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
+ test/laws/SuiteSpec.hs view
@@ -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)]+        ]+    )
+ test/test-support/Assertions/AssertionSpec.hs view
@@ -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)+    ]
+ test/test-support/Main.hs view
@@ -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+      ]
+ test/test-support/Recursion/RecursionSpec.hs view
@@ -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+    }
+ test/test-support/Resources/ResourceSpec.hs view
@@ -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"