Coverage.hs

{-# OPTIONS_GHC -Werror=incomplete-patterns #-}

-- | Reporting-only structural coverage over the checked mapped-type graph.
--
-- The report intentionally has no aggregate percentage. Private persisted event
-- payloads, mapped register cache boundaries, and queued-job history have
-- different authorities. Public contracts remain separately owned.
module Keiro.Dsl.Coverage
  ( CoverageSurface (..),
    CoverageMode (..),
    CoverageRoot (..),
    StructuralBoundary (..),
    OpaqueBoundary (..),
    JsonBoundary (..),
    NominalBoundary (..),
    SnapshotBoundary (..),
    UnsupportedSurface (..),
    CoverageCounts (..),
    CoverageSummary (..),
    CoverageFinding (..),
    CoveragePrevious (..),
    CoverageDelta (..),
    CoverageReport (..),
    coverageReport,
    coverageReportForService,
    coverageDiffReport,
    failOnOpaque,
    failOnOpaqueIncrease,
    coverageSucceeded,
    renderCoverageSummary,
    renderCoverageFinding,
    coverageFindingMessage,
    writeCoverageReport,
  )
where

import Data.Aeson (ToJSON (..), object, (.=))
import Data.Aeson qualified as Aeson
import Data.List (sortOn)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Keiro.Dsl.Grammar
import Keiro.Dsl.SemanticContract (CheckedService, checkedSpec, checkedTypeGraph, legacyCheckedService)
import Keiro.Dsl.SemanticImpact
import Keiro.Dsl.TypeGraph
import Keiro.Dsl.Validate (DiagnosticCode (..), Severity (..))
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)

data CoverageSurface
  = AggregateCommandPayload
  | PrivateEventPayload
  | SnapshotRegister
  | WorkqueuePayload
  | ReadModelQueryInput
  | ReadModelQueryResult
  | ProjectionTypedConsumer
  deriving stock (Eq, Ord, Show)

data CoverageMode = StructuralCoverage | OpaqueCoverage
  deriving stock (Eq, Ord, Show)

data CoverageRoot = CoverageRoot
  { surface :: !CoverageSurface,
    consumer :: !Text,
    path :: !Text,
    mappedType :: !Text,
    mode :: !CoverageMode,
    canonicalType :: !(Maybe Text),
    codecIdentity :: !(Maybe Text),
    codecVersion :: !(Maybe Text),
    wireFingerprint :: !Text
  }
  deriving stock (Eq, Ord, Show)

data StructuralBoundary = StructuralBoundary
  { root :: !Text,
    path :: !Text,
    mappedType :: !Text,
    canonicalType :: !Text,
    wireFingerprint :: !Text
  }
  deriving stock (Eq, Ord, Show)

data OpaqueBoundary = OpaqueBoundary
  { root :: !Text,
    path :: !Text,
    mappedType :: !Text,
    codecIdentity :: !Text,
    codecVersion :: !Text
  }
  deriving stock (Eq, Ord, Show)

data JsonBoundary = JsonBoundary
  { surface :: !CoverageSurface,
    root :: !Text,
    path :: !Text
  }
  deriving stock (Eq, Ord, Show)

data NominalBoundary = NominalBoundary
  { root :: !Text,
    path :: !Text,
    position :: !Text,
    nominal :: !Text,
    kind :: !Text,
    prefix :: !(Maybe Text),
    domainVersion :: !(Maybe Text),
    canonicalType :: !(Maybe Text),
    ownership :: !Text
  }
  deriving stock (Eq, Ord, Show)

data SnapshotBoundary = SnapshotBoundary
  { root :: !Text,
    aggregate :: !Text,
    register :: !Text,
    mappedType :: !Text,
    mode :: !CoverageMode,
    encoding :: !Text,
    invalidation :: !Text,
    wireFingerprint :: !Text,
    enabled :: !Bool
  }
  deriving stock (Eq, Ord, Show)

data UnsupportedSurface = UnsupportedSurface
  { surface :: !Text,
    support :: !Text,
    reason :: !Text
  }
  deriving stock (Eq, Ord, Show)

data CoverageCounts = CoverageCounts
  { totalRoots :: !Int,
    structuralRoots :: !Int,
    opaqueRoots :: !Int,
    jsonBoundaries :: !Int
  }
  deriving stock (Eq, Show)

data CoverageSummary = CoverageSummary
  { aggregateCommandPayloads :: !CoverageCounts,
    privateEventPayloads :: !CoverageCounts,
    snapshotRegisters :: !CoverageCounts,
    workqueuePayloads :: !CoverageCounts,
    readModelQueryInputs :: !CoverageCounts,
    readModelQueryResults :: !CoverageCounts,
    projectionTypedConsumers :: !CoverageCounts
  }
  deriving stock (Eq, Show)

data CoverageFinding = CoverageFinding
  { severity :: !Severity,
    code :: !DiagnosticCode,
    roots :: ![Text],
    message :: !Text
  }
  deriving stock (Eq, Show)

data CoveragePrevious = CoveragePrevious
  { reference :: !Text,
    summary :: !CoverageSummary,
    opaqueBoundaries :: ![OpaqueBoundary]
  }
  deriving stock (Eq, Show)

data CoverageDelta = CoverageDelta
  { aggregateCommandRootDelta :: !Int,
    privateEventRootDelta :: !Int,
    snapshotRegisterRootDelta :: !Int,
    workqueuePayloadRootDelta :: !Int,
    readModelQueryInputRootDelta :: !Int,
    readModelQueryResultRootDelta :: !Int,
    projectionTypedConsumerRootDelta :: !Int,
    opaqueBoundaryDelta :: !Int,
    addedOpaqueBoundaries :: ![OpaqueBoundary],
    removedOpaqueBoundaries :: ![OpaqueBoundary]
  }
  deriving stock (Eq, Show)

data CoverageReport = CoverageReport
  { spec :: !FilePath,
    roots :: ![CoverageRoot],
    structuralBoundaries :: ![StructuralBoundary],
    opaqueBoundaries :: ![OpaqueBoundary],
    jsonBoundaries :: ![JsonBoundary],
    nominalBoundaries :: ![NominalBoundary],
    snapshotBoundaries :: ![SnapshotBoundary],
    unsupportedSurfaces :: ![UnsupportedSurface],
    summary :: !CoverageSummary,
    findings :: ![CoverageFinding],
    previous :: !(Maybe CoveragePrevious),
    delta :: !(Maybe CoverageDelta)
  }
  deriving stock (Eq, Show)

coverageReport :: FilePath -> Spec -> Either (NonEmpty TypeGraphError) CoverageReport
coverageReport specPath = coverageReportForService specPath . legacyCheckedService

coverageReportForService :: FilePath -> CheckedService -> Either (NonEmpty TypeGraphError) CoverageReport
coverageReportForService specPath service = do
  graph <- checkedTypeGraph service
  let spec = checkedSpec service
  let impact = semanticImpact graph
      roots =
        sortOn
          (\root -> ((.path) root, (.consumer) root, (.surface) root))
          (map (coverageRoot graph) ((.roots) impact) <> map (coverageNominalRoot graph) (filter coverageOwnedNominalRoot ((.nominalRootSites) graph)))
      structural = structuralBoundaryInventory graph
      opaque = opaqueBoundaryInventory graph
      json = sortOn (.path) (jsonBoundaryInventory graph <> queueExplicitJsonBoundaries spec)
      nominals = nominalBoundaryInventory graph
      snapshots = snapshotBoundaryInventory spec graph
      summary = summarize roots json
      findings = opaqueSurfaceFindings opaque
  pure
    CoverageReport
      { spec = specPath,
        roots = roots,
        structuralBoundaries = structural,
        opaqueBoundaries = opaque,
        jsonBoundaries = json,
        nominalBoundaries = nominals,
        snapshotBoundaries = snapshots,
        unsupportedSurfaces = unsupportedInventory graph,
        summary = summary,
        findings = findings,
        previous = Nothing,
        delta = Nothing
      }

coverageDiffReport :: FilePath -> Text -> Spec -> Spec -> Either (NonEmpty TypeGraphError) CoverageReport
coverageDiffReport specPath reference oldSpec newSpec = do
  oldReport <- coverageReport (T.unpack reference <> ":" <> specPath) oldSpec
  newReport <- coverageReport specPath newSpec
  let oldOpaque = Set.fromList ((.opaqueBoundaries) oldReport)
      newOpaque = Set.fromList ((.opaqueBoundaries) newReport)
      added = Set.toAscList (newOpaque `Set.difference` oldOpaque)
      removed = Set.toAscList (oldOpaque `Set.difference` newOpaque)
      oldSummary = (.summary) oldReport
      newSummary = (.summary) newReport
      delta =
        CoverageDelta
          { aggregateCommandRootDelta = (.totalRoots) ((.aggregateCommandPayloads) newSummary) - (.totalRoots) ((.aggregateCommandPayloads) oldSummary),
            privateEventRootDelta = (.totalRoots) ((.privateEventPayloads) newSummary) - (.totalRoots) ((.privateEventPayloads) oldSummary),
            snapshotRegisterRootDelta = (.totalRoots) ((.snapshotRegisters) newSummary) - (.totalRoots) ((.snapshotRegisters) oldSummary),
            workqueuePayloadRootDelta = (.totalRoots) ((.workqueuePayloads) newSummary) - (.totalRoots) ((.workqueuePayloads) oldSummary),
            readModelQueryInputRootDelta = (.totalRoots) ((.readModelQueryInputs) newSummary) - (.totalRoots) ((.readModelQueryInputs) oldSummary),
            readModelQueryResultRootDelta = (.totalRoots) ((.readModelQueryResults) newSummary) - (.totalRoots) ((.readModelQueryResults) oldSummary),
            projectionTypedConsumerRootDelta = (.totalRoots) ((.projectionTypedConsumers) newSummary) - (.totalRoots) ((.projectionTypedConsumers) oldSummary),
            opaqueBoundaryDelta = length added - length removed,
            addedOpaqueBoundaries = added,
            removedOpaqueBoundaries = removed
          }
      addedFindings =
        [ CoverageFinding
            { severity = Warning,
              code = CoverageOpaqueBoundaryAdded,
              roots = [(.root) boundary],
              message = "opaque boundary added at " <> (.path) boundary
            }
        | boundary <- added
        ]
  pure $
    replaceCoverageReportComparison
      (newReport.findings <> addedFindings)
      ( Just
          CoveragePrevious
            { reference = reference,
              summary = oldSummary,
              opaqueBoundaries = oldReport.opaqueBoundaries
            }
      )
      (Just delta)
      newReport

failOnOpaque :: CoverageReport -> CoverageReport
failOnOpaque report
  | null boundaries = report
  | otherwise = replaceCoverageReportFindings (report.findings <> [gateFinding "opaque persisted boundaries are forbidden by --fail-on-opaque" boundaries]) report
  where
    boundaries = (.opaqueBoundaries) report

failOnOpaqueIncrease :: CoverageReport -> CoverageReport
failOnOpaqueIncrease report = case (.delta) report of
  Just delta
    | not (null ((.addedOpaqueBoundaries) delta)) ->
        replaceCoverageReportFindings
          (report.findings <> [gateFinding "new opaque persisted boundaries are forbidden by --fail-on-opaque-increase" delta.addedOpaqueBoundaries])
          report
  _ -> report

replaceCoverageReportFindings :: [CoverageFinding] -> CoverageReport -> CoverageReport
replaceCoverageReportFindings findings report =
  replaceCoverageReportComparison findings report.previous report.delta report

replaceCoverageReportComparison :: [CoverageFinding] -> Maybe CoveragePrevious -> Maybe CoverageDelta -> CoverageReport -> CoverageReport
replaceCoverageReportComparison findings previous delta report =
  CoverageReport
    { spec = report.spec,
      roots = report.roots,
      structuralBoundaries = report.structuralBoundaries,
      opaqueBoundaries = report.opaqueBoundaries,
      jsonBoundaries = report.jsonBoundaries,
      nominalBoundaries = report.nominalBoundaries,
      snapshotBoundaries = report.snapshotBoundaries,
      unsupportedSurfaces = report.unsupportedSurfaces,
      summary = report.summary,
      findings,
      previous,
      delta
    }

coverageSucceeded :: CoverageReport -> Bool
coverageSucceeded = all ((/= Error) . (.severity)) . (.findings)

renderCoverageSummary :: CoverageReport -> Text
renderCoverageSummary report =
  T.unlines
    [ "structural/opaque boundaries (reporting only):",
      "  aggregate-command-payloads: " <> renderCounts ((.aggregateCommandPayloads) summary) <> "; encoding=consumer-build-only",
      "  private-event-payloads: " <> renderCounts ((.privateEventPayloads) summary),
      "  snapshot-registers: " <> renderCounts ((.snapshotRegisters) summary) <> "; encoding=consumer-json-cache; invalidation=tracked",
      "  queue-payloads: " <> renderCounts ((.workqueuePayloads) summary) <> "; encoding=queue-envelope-v1; migration=drain-or-transitional-codec",
      "  read-model-query-inputs: " <> renderCounts ((.readModelQueryInputs) summary) <> "; encoding=generated-haskell-api",
      "  read-model-query-results: " <> renderCounts ((.readModelQueryResults) summary) <> "; encoding=generated-haskell-api",
      "  projection-typed-consumers: " <> renderCounts ((.projectionTypedConsumers) summary) <> "; encoding=inherited-event-source",
      "  public-contracts: not-applicable (separately owned grammar)"
    ]
  where
    summary = (.summary) report
    renderCounts counts =
      T.pack (show ((.totalRoots) counts))
        <> " mapped roots ("
        <> T.pack (show ((.structuralRoots) counts))
        <> " structural, "
        <> T.pack (show ((.opaqueRoots) counts))
        <> " opaque, "
        <> T.pack (show ((.jsonBoundaries) counts))
        <> " Json boundaries)"

renderCoverageFinding :: FilePath -> CoverageFinding -> Text
renderCoverageFinding specPath finding =
  T.pack specPath
    <> ":0: "
    <> severityText ((.severity) finding)
    <> "["
    <> T.pack (show ((.code) finding))
    <> "]: "
    <> coverageFindingMessage finding
  where
    severityText Error = "error"
    severityText Warning = "warning"

-- | The finding's message with its root list appended, shared by the rendered
-- stderr line and the machine check-report entry so both say the same thing.
coverageFindingMessage :: CoverageFinding -> Text
coverageFindingMessage finding = (.message) finding <> rootsSuffix
  where
    rootsSuffix = case (.roots) finding of
      [] -> ""
      roots -> " (roots: " <> T.intercalate ", " roots <> ")"

writeCoverageReport :: FilePath -> CoverageReport -> IO ()
writeCoverageReport path report = do
  createDirectoryIfMissing True (takeDirectory path)
  Aeson.encodeFile path report

persistedSites :: TypeGraph -> [UseSite]
persistedSites = filter (isPersisted . (.root)) . (.useSites)
  where
    isPersisted RootEventField {} = True
    isPersisted RootRegister {} = True
    isPersisted RootCommandField {} = False
    isPersisted RootWorkqueueField {} = True
    isPersisted RootReadModelQueryInput {} = False
    isPersisted RootReadModelQueryResult {} = False
    isPersisted RootContractField {} = False

coverageOwnedNominalRoot :: NominalRootSite -> Bool
coverageOwnedNominalRoot site = case (.root) site of
  RootContractField {} -> False
  _ -> True

coverageRoot :: TypeGraph -> MappedRoot -> CoverageRoot
coverageRoot graph mappedRoot =
  let site :: UseSite
      site = (.useSite) mappedRoot
      key = (.declaration) mappedRoot
      path = renderUsePath (UsePath ((.root) site) ([SegDecl (unMappedKey key)] <> useSiteSegments graph site))
      fingerprint = wireFingerprint graph (unMappedKey key)
   in case Map.lookup key ((.declarations) graph) of
        Just (ResolvedStructural declaration _) ->
          CoverageRoot
            { surface = rootKindSurface ((.kind) mappedRoot),
              consumer = mappedConsumerIdentity ((.consumer) mappedRoot),
              path = path,
              mappedType = unMappedKey key,
              mode = StructuralCoverage,
              canonicalType = Just (unCanonicalTypeId ((.canonical) declaration)),
              codecIdentity = Nothing,
              codecVersion = Nothing,
              wireFingerprint = fingerprint
            }
        Just (ResolvedOpaque declaration) ->
          CoverageRoot
            { surface = rootKindSurface ((.kind) mappedRoot),
              consumer = mappedConsumerIdentity ((.consumer) mappedRoot),
              path = path,
              mappedType = unMappedKey key,
              mode = OpaqueCoverage,
              canonicalType = Nothing,
              codecIdentity = Just (unCodecIdentity ((.codecIdentity) declaration)),
              codecVersion = Just (unCodecVersion ((.codecVersion) declaration)),
              wireFingerprint = fingerprint
            }
        Nothing -> error "coverageRoot: resolved use-site key missing from graph"

coverageNominalRoot :: TypeGraph -> NominalRootSite -> CoverageRoot
coverageNominalRoot graph site =
  case Map.lookup ((.nominal) site) ((.nominalLeaves) graph) of
    Nothing -> error "coverageNominalRoot: resolved nominal use-site missing from graph"
    Just leaf ->
      CoverageRoot
        { surface = rootRefSurface ((.root) site),
          consumer = nominalRootConsumer ((.root) site),
          path = renderUsePath (UsePath ((.root) site) ([SegNominal ((.nominal) site)] <> (.segments) site)),
          mappedType = (.nominal) site,
          mode = StructuralCoverage,
          canonicalType = case (.ownership) leaf of GeneratedLeaf -> Nothing; ConsumerLeaf binding -> Just (unCanonicalTypeId ((.canonical) binding)),
          codecIdentity = Nothing,
          codecVersion = Nothing,
          wireFingerprint = nominalWireFingerprint leaf
        }

structuralBoundaryInventory :: TypeGraph -> [StructuralBoundary]
structuralBoundaryInventory graph =
  sortOn
    (.path)
    [ StructuralBoundary
        { root = rootText ((.root) path),
          path = renderUsePath path,
          mappedType = (.name) declaration,
          canonicalType = unCanonicalTypeId ((.canonical) declaration),
          wireFingerprint = wireFingerprint graph ((.name) declaration)
        }
    | ResolvedStructural declaration _ <- Map.elems ((.declarations) graph),
      path <- usePaths graph ((.name) declaration),
      isWireSite ((.root) path)
    ]

opaqueBoundaryInventory :: TypeGraph -> [OpaqueBoundary]
opaqueBoundaryInventory graph =
  sortOn
    (.path)
    [ OpaqueBoundary
        { root = rootText ((.root) path),
          path = renderUsePath path,
          mappedType = (.name) declaration,
          codecIdentity = unCodecIdentity ((.codecIdentity) declaration),
          codecVersion = unCodecVersion ((.codecVersion) declaration)
        }
    | ResolvedOpaque declaration <- Map.elems ((.declarations) graph),
      path <- usePaths graph ((.name) declaration),
      isWireSite ((.root) path)
    ]

nominalBoundaryInventory :: TypeGraph -> [NominalBoundary]
nominalBoundaryInventory graph =
  sortOn
    (.path)
    [ NominalBoundary
        { root = rootText ((.root) path),
          path = renderUsePath path,
          position = if SegMapKey `elem` (.segments) path then "key" else "value",
          nominal = (.name) leaf,
          kind = case (.kind) leaf of NominalIdLeaf {} -> "id"; NominalEnumLeaf {} -> "enum"; NominalScalarLeaf {} -> "scalar",
          prefix = case (.kind) leaf of NominalIdLeaf value -> Just value; NominalEnumLeaf {} -> Nothing; NominalScalarLeaf {} -> Nothing,
          domainVersion = case (.kind) leaf of NominalIdLeaf {} -> Just "keiro-dsl/id-domain/typeid-v7/1"; NominalEnumLeaf {} -> Nothing; NominalScalarLeaf {} -> Nothing,
          canonicalType = case (.ownership) leaf of GeneratedLeaf -> Nothing; ConsumerLeaf binding -> Just (unCanonicalTypeId ((.canonical) binding)),
          ownership = case (.ownership) leaf of GeneratedLeaf -> "generated"; ConsumerLeaf {} -> "consumer"
        }
    | leaf <- Map.elems ((.nominalLeaves) graph),
      path <- nominalUsePaths graph ((.name) leaf),
      isWireSite ((.root) path)
    ]

jsonBoundaryInventory :: TypeGraph -> [JsonBoundary]
jsonBoundaryInventory graph =
  sortOn
    (.path)
    [ boundary site completeSegments
    | site <- persistedSites graph,
      isWireSite ((.root) site),
      segments <- jsonPathsFromDecl graph Set.empty (useSiteKey site),
      let completeSegments = [SegDecl (unMappedKey (useSiteKey site))] <> useSiteSegments graph site <> segments
    ]
  where
    boundary site segments =
      JsonBoundary
        { surface = useSiteSurface site,
          root = rootText ((.root) site),
          path = renderUsePath (UsePath ((.root) site) segments)
        }

queueExplicitJsonBoundaries :: Spec -> [JsonBoundary]
queueExplicitJsonBoundaries spec =
  [ JsonBoundary
      { surface = WorkqueuePayload,
        root = root,
        path = root <> renderSegments segments
      }
  | NWorkqueue workqueue <- (.nodes) spec,
    field <- (.payload) workqueue,
    TypedQueueExpression expression <- [(.valueType) field],
    segments <- explicitJsonPaths expression,
    let root = "workqueue " <> (.name) workqueue <> " payload ." <> (.name) field
  ]
  where
    explicitJsonPaths TJson = [[]]
    explicitJsonPaths (TOptional value) = map (SegOptional :) (explicitJsonPaths value)
    explicitJsonPaths (TList value) = map (SegElem :) (explicitJsonPaths value)
    explicitJsonPaths (TMap value) = map (SegMapValue :) (explicitJsonPaths value)
    explicitJsonPaths (TKeyedMap _ value) = map (SegMapValue :) (explicitJsonPaths value)
    explicitJsonPaths _ = []
    renderSegments = T.concat . map renderSegment
    renderSegment SegOptional = " optional"
    renderSegment SegElem = " []"
    renderSegment SegMapKey = " {key}"
    renderSegment SegMapValue = " {}"
    renderSegment (SegField name key)
      | name == key = " ." <> name
      | otherwise = " ." <> name <> " as " <> T.pack (show key)
    renderSegment (SegArm _ tag) = " arm " <> T.pack (show tag)
    renderSegment (SegDecl name) = " : " <> name
    renderSegment (SegNominal name) = " : " <> name

snapshotBoundaryInventory :: Spec -> TypeGraph -> [SnapshotBoundary]
snapshotBoundaryInventory spec graph =
  sortOn
    (.root)
    ( [ SnapshotBoundary
          { root = renderUsePath (UsePath ((.root) site) [SegDecl (unMappedKey key)]),
            aggregate = aggregate,
            register = register,
            mappedType = unMappedKey key,
            mode = declarationMode declaration,
            encoding = "consumer-json-cache",
            invalidation = "tracked-by-mapped-wire-fingerprint",
            wireFingerprint = wireFingerprint graph (unMappedKey key),
            enabled = aggregateHasSnapshot aggregate
          }
      | site@UseSite {root = RootRegister aggregate register, mappedKey = key} <- persistedSites graph,
        Just declaration <- [Map.lookup key ((.declarations) graph)]
      ]
        <> [ SnapshotBoundary
               { root = renderUsePath (UsePath ((.root) site) ([SegNominal ((.nominal) site)] <> (.segments) site)),
                 aggregate = aggregate,
                 register = register,
                 mappedType = (.nominal) site,
                 mode = StructuralCoverage,
                 encoding = "consumer-json-cache",
                 invalidation = "tracked-by-nominal-wire-fingerprint",
                 wireFingerprint = nominalWireFingerprint leaf,
                 enabled = aggregateHasSnapshot aggregate
               }
           | site@NominalRootSite {root = RootRegister aggregate register} <- (.nominalRootSites) graph,
             Just leaf <- [Map.lookup ((.nominal) site) ((.nominalLeaves) graph)]
           ]
    )
  where
    aggregateHasSnapshot name =
      any
        (\case NAggregate aggregate -> (.name) aggregate == name && maybe False (const True) ((.snapshot) aggregate); _ -> False)
        ((.nodes) spec)

jsonPathsFromDecl :: TypeGraph -> Set.Set MappedKey -> MappedKey -> [[PathSeg]]
jsonPathsFromDecl graph visited key
  | key `Set.member` visited = []
  | otherwise = case Map.lookup key ((.declarations) graph) of
      Nothing -> []
      Just declaration ->
        foldMappedDecl
          MappedDeclAlgebra
            { onStructuralDecl = \_ shape -> jsonPathsFromShape graph (Set.insert key visited) shape,
              onOpaqueDecl = const []
            }
          declaration

jsonPathsFromShape :: TypeGraph -> Set.Set MappedKey -> ResolvedMappedShape -> [[PathSeg]]
jsonPathsFromShape graph visited =
  foldMappedShape
    MappedShapeAlgebra
      { onRecord = \_ _ fields ->
          concat
            [ map (SegField ((.haskell) field) ((.key) field) :) (jsonPathsFromExpr graph visited ((.valueType) field))
            | field <- fields
            ],
        onEnum = const [],
        onUnion = \_ arms ->
          concat
            [ map (SegArm ((.ctor) arm) ((.tag) arm) :) (maybe [] (jsonPathsFromExpr graph visited) ((.payload) arm))
            | arm <- arms
            ]
      }

jsonPathsFromExpr :: TypeGraph -> Set.Set MappedKey -> ResolvedTypeExpr -> [[PathSeg]]
jsonPathsFromExpr graph visited =
  foldTypeExpr
    TypeExprAlgebra
      { onText = [],
        onInt = [],
        onInteger = [],
        onBool = [],
        onNatural = [],
        onTime = [],
        onJson = [[]],
        onOptional = map (SegOptional :),
        onList = map (SegElem :),
        onMap = map (SegMapValue :),
        onKeyedMap = \_ -> map (SegMapValue :),
        onRef = \key -> map (SegDecl (unMappedKey key) :) (jsonPathsFromDecl graph visited key),
        onNominal = const []
      }

summarize :: [CoverageRoot] -> [JsonBoundary] -> CoverageSummary
summarize roots json =
  CoverageSummary
    { aggregateCommandPayloads = countsFor AggregateCommandPayload,
      privateEventPayloads = countsFor PrivateEventPayload,
      snapshotRegisters = countsFor SnapshotRegister,
      workqueuePayloads = countsFor WorkqueuePayload,
      readModelQueryInputs = countsFor ReadModelQueryInput,
      readModelQueryResults = countsFor ReadModelQueryResult,
      projectionTypedConsumers = countsFor ProjectionTypedConsumer
    }
  where
    countsFor surface =
      let matching = filter ((== surface) . (.surface)) roots
          jsonCount = length (filter ((== surface) . (.surface)) json)
       in CoverageCounts
            { totalRoots = length matching,
              structuralRoots = length (filter ((== StructuralCoverage) . (.mode)) matching),
              opaqueRoots = length (filter ((== OpaqueCoverage) . (.mode)) matching),
              jsonBoundaries = jsonCount
            }

opaqueSurfaceFindings :: [OpaqueBoundary] -> [CoverageFinding]
opaqueSurfaceFindings boundaries =
  [ CoverageFinding
      { severity = Warning,
        code = CoverageOpaqueSurface,
        roots = [root],
        message = "persisted mapped root contains opaque mapped boundaries"
      }
  | root <- Set.toAscList (Set.fromList (map (.root) boundaries))
  ]

gateFinding :: Text -> [OpaqueBoundary] -> CoverageFinding
gateFinding message boundaries =
  CoverageFinding
    { severity = Error,
      code = CoverageOpaqueGateExceeded,
      roots = Set.toAscList (Set.fromList (map (.root) boundaries)),
      message = message
    }

unsupportedInventory :: TypeGraph -> [UnsupportedSurface]
unsupportedInventory graph =
  [ UnsupportedSurface
      { surface = "public-contracts",
        support = "not-applicable",
        reason = "public contracts have a separately owned grammar and compatibility surface"
      }
  ]
    <> [ UnsupportedSurface
           { surface = unsupportedProjectionIdentity boundary,
             support = "operational-only",
             reason = "heterogeneous projection sources have no single generated event type or mapped declaration root"
           }
       | boundary <- (.unsupportedProjectionSources) graph
       ]
  where
    unsupportedProjectionIdentity (UnsupportedCatalogCategory owner categoryName) = "projection-category:" <> owner <> ":" <> categoryName
    unsupportedProjectionIdentity (UnsupportedCatalogAll owner) = "projection-all:" <> owner

useSiteKey :: UseSite -> MappedKey
useSiteKey = (.mappedKey)

useSiteSurface :: UseSite -> CoverageSurface
useSiteSurface = rootRefSurface . (.root)

rootRefSurface :: RootRef -> CoverageSurface
rootRefSurface RootCommandField {} = AggregateCommandPayload
rootRefSurface RootEventField {} = PrivateEventPayload
rootRefSurface RootRegister {} = SnapshotRegister
rootRefSurface RootWorkqueueField {} = WorkqueuePayload
rootRefSurface RootReadModelQueryInput {} = ReadModelQueryInput
rootRefSurface RootReadModelQueryResult {} = ReadModelQueryResult
rootRefSurface RootContractField {} = error "public contracts have a separately owned coverage surface"

rootKindSurface :: MappedRootKind -> CoverageSurface
rootKindSurface MappedCommandFieldRoot = AggregateCommandPayload
rootKindSurface MappedEventFieldRoot = PrivateEventPayload
rootKindSurface MappedRegisterRoot = SnapshotRegister
rootKindSurface MappedWorkqueueFieldRoot = WorkqueuePayload
rootKindSurface MappedReadModelQueryInputRoot = ReadModelQueryInput
rootKindSurface MappedReadModelQueryResultRoot = ReadModelQueryResult
rootKindSurface MappedRouterSelectionQueryInputRoot = ReadModelQueryInput
rootKindSurface MappedRouterSelectionPredicateRoot = ReadModelQueryResult
rootKindSurface MappedRouterSelectionRecipientRoot = ReadModelQueryResult
rootKindSurface MappedRouterSelectionCommandFieldRoot = ReadModelQueryResult
rootKindSurface MappedProjectionEventRoot = ProjectionTypedConsumer

isWireSite :: RootRef -> Bool
isWireSite RootEventField {} = True
isWireSite RootWorkqueueField {} = True
isWireSite RootRegister {} = False
isWireSite RootCommandField {} = False
isWireSite RootReadModelQueryInput {} = False
isWireSite RootReadModelQueryResult {} = False
isWireSite RootContractField {} = False

rootText :: RootRef -> Text
rootText site = renderUsePath (UsePath site [])

nominalRootConsumer :: RootRef -> Text
nominalRootConsumer = \case
  RootCommandField aggregate _ _ -> aggregate
  RootEventField aggregate _ _ -> aggregate
  RootRegister aggregate _ -> aggregate
  RootWorkqueueField workqueue _ -> "workqueue:" <> workqueue
  RootReadModelQueryInput readModel -> "read-model-query:" <> readModel <> ":input"
  RootReadModelQueryResult readModel -> "read-model-query:" <> readModel <> ":result"
  RootContractField {} -> error "public contracts have a separately owned coverage surface"

declarationMode :: ResolvedMappedDecl -> CoverageMode
declarationMode =
  foldMappedDecl
    MappedDeclAlgebra
      { onStructuralDecl = \_ _ -> StructuralCoverage,
        onOpaqueDecl = const OpaqueCoverage
      }

instance ToJSON CoverageSurface where
  toJSON AggregateCommandPayload = toJSON ("aggregate-command-payload" :: Text)
  toJSON PrivateEventPayload = toJSON ("private-event-payload" :: Text)
  toJSON SnapshotRegister = toJSON ("snapshot-register" :: Text)
  toJSON WorkqueuePayload = toJSON ("workqueue-payload" :: Text)
  toJSON ReadModelQueryInput = toJSON ("read-model-query-input" :: Text)
  toJSON ReadModelQueryResult = toJSON ("read-model-query-result" :: Text)
  toJSON ProjectionTypedConsumer = toJSON ("projection-typed-consumer" :: Text)

instance ToJSON CoverageMode where
  toJSON StructuralCoverage = toJSON ("structural" :: Text)
  toJSON OpaqueCoverage = toJSON ("opaque" :: Text)

instance ToJSON NominalBoundary where
  toJSON boundary =
    object
      [ "root" .= (.root) boundary,
        "path" .= (.path) boundary,
        "position" .= (.position) boundary,
        "nominal" .= (.nominal) boundary,
        "kind" .= (.kind) boundary,
        "prefix" .= (.prefix) boundary,
        "domainVersion" .= (.domainVersion) boundary,
        "canonicalType" .= (.canonicalType) boundary,
        "ownership" .= (.ownership) boundary
      ]

instance ToJSON CoverageRoot where
  toJSON root =
    object
      [ "surface" .= (.surface) root,
        "consumer" .= (.consumer) root,
        "path" .= (.path) root,
        "mappedType" .= (.mappedType) root,
        "mode" .= (.mode) root,
        "canonicalType" .= (.canonicalType) root,
        "codecIdentity" .= (.codecIdentity) root,
        "codecVersion" .= (.codecVersion) root,
        "wireFingerprint" .= (.wireFingerprint) root
      ]

instance ToJSON StructuralBoundary where
  toJSON boundary =
    object
      [ "root" .= (.root) boundary,
        "path" .= (.path) boundary,
        "mappedType" .= (.mappedType) boundary,
        "canonicalType" .= (.canonicalType) boundary,
        "wireFingerprint" .= (.wireFingerprint) boundary
      ]

instance ToJSON OpaqueBoundary where
  toJSON boundary =
    object
      [ "root" .= (.root) boundary,
        "path" .= (.path) boundary,
        "mappedType" .= (.mappedType) boundary,
        "codecIdentity" .= (.codecIdentity) boundary,
        "codecVersion" .= (.codecVersion) boundary
      ]

instance ToJSON JsonBoundary where
  toJSON boundary = object ["surface" .= (.surface) boundary, "root" .= (.root) boundary, "path" .= (.path) boundary]

instance ToJSON SnapshotBoundary where
  toJSON boundary =
    object
      [ "root" .= (.root) boundary,
        "aggregate" .= (.aggregate) boundary,
        "register" .= (.register) boundary,
        "mappedType" .= (.mappedType) boundary,
        "mode" .= (.mode) boundary,
        "snapshotEncoding" .= (.encoding) boundary,
        "invalidation" .= (.invalidation) boundary,
        "wireFingerprint" .= (.wireFingerprint) boundary,
        "snapshotEnabled" .= (.enabled) boundary
      ]

instance ToJSON UnsupportedSurface where
  toJSON surface =
    object
      [ "surface" .= (.surface) surface,
        "support" .= (.support) surface,
        "reason" .= (.reason) surface
      ]

instance ToJSON CoverageCounts where
  toJSON counts =
    object
      [ "totalRoots" .= (.totalRoots) counts,
        "structuralRoots" .= (.structuralRoots) counts,
        "opaqueRoots" .= (.opaqueRoots) counts,
        "jsonBoundaries" .= (.jsonBoundaries) counts
      ]

instance ToJSON CoverageSummary where
  toJSON summary =
    object
      [ "aggregateCommandPayloads" .= (.aggregateCommandPayloads) summary,
        "privateEventPayloads" .= (.privateEventPayloads) summary,
        "snapshotRegisters" .= (.snapshotRegisters) summary,
        "workqueuePayloads" .= (.workqueuePayloads) summary,
        "readModelQueryInputs" .= (.readModelQueryInputs) summary,
        "readModelQueryResults" .= (.readModelQueryResults) summary,
        "projectionTypedConsumers" .= (.projectionTypedConsumers) summary
      ]

instance ToJSON CoverageFinding where
  toJSON finding =
    object
      [ "severity" .= severityValue ((.severity) finding),
        "code" .= show ((.code) finding),
        "roots" .= (.roots) finding,
        "message" .= (.message) finding
      ]
    where
      -- One severity vocabulary across every keiro-dsl JSON report. The check
      -- report has always spelled this "warning"; coverage spelled the same
      -- severity "advisory" until ExecPlan 199 unified them.
      severityValue Error = "error" :: Text
      severityValue Warning = "warning"

instance ToJSON CoveragePrevious where
  toJSON previous =
    object
      [ "reference" .= (.reference) previous,
        "summary" .= (.summary) previous,
        "opaqueBoundaries" .= (.opaqueBoundaries) previous
      ]

instance ToJSON CoverageDelta where
  toJSON delta =
    object
      [ "aggregateCommandRootDelta" .= (.aggregateCommandRootDelta) delta,
        "privateEventRootDelta" .= (.privateEventRootDelta) delta,
        "snapshotRegisterRootDelta" .= (.snapshotRegisterRootDelta) delta,
        "workqueuePayloadRootDelta" .= (.workqueuePayloadRootDelta) delta,
        "readModelQueryInputRootDelta" .= (.readModelQueryInputRootDelta) delta,
        "readModelQueryResultRootDelta" .= (.readModelQueryResultRootDelta) delta,
        "projectionTypedConsumerRootDelta" .= (.projectionTypedConsumerRootDelta) delta,
        "opaqueBoundaryDelta" .= (.opaqueBoundaryDelta) delta,
        "addedOpaqueBoundaries" .= (.addedOpaqueBoundaries) delta,
        "removedOpaqueBoundaries" .= (.removedOpaqueBoundaries) delta
      ]

instance ToJSON CoverageReport where
  toJSON report =
    object
      [ "schema" .= ("keiro-dsl/coverage-report/1" :: Text),
        "spec" .= (.spec) report,
        "roots" .= (.roots) report,
        "structuralBoundaries" .= (.structuralBoundaries) report,
        "opaqueBoundaries" .= (.opaqueBoundaries) report,
        "jsonBoundaries" .= (.jsonBoundaries) report,
        "nominalBoundaries" .= (.nominalBoundaries) report,
        "snapshotBoundaries" .= (.snapshotBoundaries) report,
        "unsupportedSurfaces" .= (.unsupportedSurfaces) report,
        "summary" .= (.summary) report,
        "findings" .= (.findings) report,
        "previous" .= (.previous) report,
        "delta" .= (.delta) report
      ]