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 (..),
    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
  { rootSurface :: !CoverageSurface,
    rootConsumer :: !Text,
    rootPath :: !Text,
    rootMappedType :: !Text,
    rootMode :: !CoverageMode,
    rootCanonicalType :: !(Maybe Text),
    rootCodecIdentity :: !(Maybe Text),
    rootCodecVersion :: !(Maybe Text),
    rootWireFingerprint :: !Text
  }
  deriving stock (Eq, Ord, Show)

data StructuralBoundary = StructuralBoundary
  { structuralRoot :: !Text,
    structuralPath :: !Text,
    structuralMappedType :: !Text,
    structuralCanonicalType :: !Text,
    structuralWireFingerprint :: !Text
  }
  deriving stock (Eq, Ord, Show)

data OpaqueBoundary = OpaqueBoundary
  { opaqueRoot :: !Text,
    opaquePath :: !Text,
    opaqueMappedType :: !Text,
    opaqueCodecIdentity :: !Text,
    opaqueCodecVersion :: !Text
  }
  deriving stock (Eq, Ord, Show)

data JsonBoundary = JsonBoundary
  { jsonSurface :: !CoverageSurface,
    jsonRoot :: !Text,
    jsonPath :: !Text
  }
  deriving stock (Eq, Ord, Show)

data SnapshotBoundary = SnapshotBoundary
  { snapshotRoot :: !Text,
    snapshotAggregate :: !Text,
    snapshotRegister :: !Text,
    snapshotMappedType :: !Text,
    snapshotMode :: !CoverageMode,
    snapshotEncoding :: !Text,
    snapshotInvalidation :: !Text,
    snapshotWireFingerprint :: !Text,
    snapshotEnabled :: !Bool
  }
  deriving stock (Eq, Ord, Show)

data UnsupportedSurface = UnsupportedSurface
  { unsupportedSurface :: !Text,
    unsupportedSupport :: !Text,
    unsupportedReason :: !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
  { findingSeverity :: !Severity,
    findingCode :: !DiagnosticCode,
    findingRoots :: ![Text],
    findingMessage :: !Text
  }
  deriving stock (Eq, Show)

data CoveragePrevious = CoveragePrevious
  { previousReference :: !Text,
    previousSummary :: !CoverageSummary,
    previousOpaqueBoundaries :: ![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
  { coverageSpec :: !FilePath,
    coverageRoots :: ![CoverageRoot],
    coverageStructuralBoundaries :: ![StructuralBoundary],
    coverageOpaqueBoundaries :: ![OpaqueBoundary],
    coverageJsonBoundaries :: ![JsonBoundary],
    coverageSnapshotBoundaries :: ![SnapshotBoundary],
    coverageUnsupportedSurfaces :: ![UnsupportedSurface],
    coverageSummary :: !CoverageSummary,
    coverageFindings :: ![CoverageFinding],
    coveragePrevious :: !(Maybe CoveragePrevious),
    coverageDelta :: !(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 -> (rootPath root, rootConsumer root, rootSurface root)) (map (coverageRoot graph) (impactRoots impact))
      structural = structuralBoundaryInventory graph
      opaque = opaqueBoundaryInventory graph
      json = sortOn jsonPath (jsonBoundaryInventory graph <> queueExplicitJsonBoundaries spec)
      snapshots = snapshotBoundaryInventory spec graph
      summary = summarize roots json
      findings = opaqueSurfaceFindings opaque
  pure
    CoverageReport
      { coverageSpec = specPath,
        coverageRoots = roots,
        coverageStructuralBoundaries = structural,
        coverageOpaqueBoundaries = opaque,
        coverageJsonBoundaries = json,
        coverageSnapshotBoundaries = snapshots,
        coverageUnsupportedSurfaces = unsupportedInventory graph,
        coverageSummary = summary,
        coverageFindings = findings,
        coveragePrevious = Nothing,
        coverageDelta = 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 (coverageOpaqueBoundaries oldReport)
      newOpaque = Set.fromList (coverageOpaqueBoundaries newReport)
      added = Set.toAscList (newOpaque `Set.difference` oldOpaque)
      removed = Set.toAscList (oldOpaque `Set.difference` newOpaque)
      oldSummary = coverageSummary oldReport
      newSummary = coverageSummary 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
            { findingSeverity = Warning,
              findingCode = CoverageOpaqueBoundaryAdded,
              findingRoots = [opaqueRoot boundary],
              findingMessage = "opaque boundary added at " <> opaquePath boundary
            }
        | boundary <- added
        ]
  pure
    newReport
      { coverageFindings = coverageFindings newReport <> addedFindings,
        coveragePrevious =
          Just
            CoveragePrevious
              { previousReference = reference,
                previousSummary = oldSummary,
                previousOpaqueBoundaries = coverageOpaqueBoundaries oldReport
              },
        coverageDelta = Just delta
      }

failOnOpaque :: CoverageReport -> CoverageReport
failOnOpaque report
  | null boundaries = report
  | otherwise = report {coverageFindings = coverageFindings report <> [gateFinding "opaque persisted boundaries are forbidden by --fail-on-opaque" boundaries]}
  where
    boundaries = coverageOpaqueBoundaries report

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

coverageSucceeded :: CoverageReport -> Bool
coverageSucceeded = all ((/= Error) . findingSeverity) . coverageFindings

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 = coverageSummary 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 (findingSeverity finding)
    <> "["
    <> T.pack (show (findingCode 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 = findingMessage finding <> rootsSuffix
  where
    rootsSuffix = case findingRoots 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 . tgUseSites
  where
    isPersisted RootEventField {} = True
    isPersisted RootRegister {} = True
    isPersisted RootCommandField {} = False
    isPersisted RootWorkqueueField {} = True
    isPersisted RootReadModelQueryInput {} = False
    isPersisted RootReadModelQueryResult {} = False

coverageRoot :: TypeGraph -> MappedRoot -> CoverageRoot
coverageRoot graph mappedRoot =
  let site = mappedRootUseSite mappedRoot
      key = mappedRootDeclaration mappedRoot
      path = renderUsePath (UsePath site (useSiteSegments graph site))
      fingerprint = wireFingerprint graph (unMappedKey key)
   in case Map.lookup key (tgDeclarations graph) of
        Just (ResolvedStructural declaration _) ->
          CoverageRoot
            { rootSurface = rootKindSurface (mappedRootKind mappedRoot),
              rootConsumer = mappedConsumerIdentity (mappedRootConsumer mappedRoot),
              rootPath = path,
              rootMappedType = unMappedKey key,
              rootMode = StructuralCoverage,
              rootCanonicalType = Just (unCanonicalTypeId (sdCanonical declaration)),
              rootCodecIdentity = Nothing,
              rootCodecVersion = Nothing,
              rootWireFingerprint = fingerprint
            }
        Just (ResolvedOpaque declaration) ->
          CoverageRoot
            { rootSurface = rootKindSurface (mappedRootKind mappedRoot),
              rootConsumer = mappedConsumerIdentity (mappedRootConsumer mappedRoot),
              rootPath = path,
              rootMappedType = unMappedKey key,
              rootMode = OpaqueCoverage,
              rootCanonicalType = Nothing,
              rootCodecIdentity = Just (unCodecIdentity (odCodecIdentity declaration)),
              rootCodecVersion = Just (unCodecVersion (odCodecVersion declaration)),
              rootWireFingerprint = fingerprint
            }
        Nothing -> error "coverageRoot: resolved use-site key missing from graph"

structuralBoundaryInventory :: TypeGraph -> [StructuralBoundary]
structuralBoundaryInventory graph =
  sortOn
    structuralPath
    [ StructuralBoundary
        { structuralRoot = rootText (upRoot path),
          structuralPath = renderUsePath path,
          structuralMappedType = sdName declaration,
          structuralCanonicalType = unCanonicalTypeId (sdCanonical declaration),
          structuralWireFingerprint = wireFingerprint graph (sdName declaration)
        }
    | ResolvedStructural declaration _ <- Map.elems (tgDeclarations graph),
      path <- usePaths graph (sdName declaration),
      isWireSite (upRoot path)
    ]

opaqueBoundaryInventory :: TypeGraph -> [OpaqueBoundary]
opaqueBoundaryInventory graph =
  sortOn
    opaquePath
    [ OpaqueBoundary
        { opaqueRoot = rootText (upRoot path),
          opaquePath = renderUsePath path,
          opaqueMappedType = odName declaration,
          opaqueCodecIdentity = unCodecIdentity (odCodecIdentity declaration),
          opaqueCodecVersion = unCodecVersion (odCodecVersion declaration)
        }
    | ResolvedOpaque declaration <- Map.elems (tgDeclarations graph),
      path <- usePaths graph (odName declaration),
      isWireSite (upRoot path)
    ]

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

queueExplicitJsonBoundaries :: Spec -> [JsonBoundary]
queueExplicitJsonBoundaries spec =
  [ JsonBoundary
      { jsonSurface = WorkqueuePayload,
        jsonRoot = root,
        jsonPath = root <> renderSegments segments
      }
  | NWorkqueue workqueue <- specNodes spec,
    field <- wqPayload workqueue,
    TypedQueueExpression expression <- [wqfType field],
    segments <- explicitJsonPaths expression,
    let root = "workqueue " <> wqName workqueue <> " payload ." <> wqfName 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 _ = []
    renderSegments = T.concat . map renderSegment
    renderSegment SegOptional = " optional"
    renderSegment SegElem = " []"
    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

snapshotBoundaryInventory :: Spec -> TypeGraph -> [SnapshotBoundary]
snapshotBoundaryInventory spec graph =
  sortOn
    snapshotRoot
    [ SnapshotBoundary
        { snapshotRoot = renderUsePath (UsePath site []),
          snapshotAggregate = aggregate,
          snapshotRegister = register,
          snapshotMappedType = unMappedKey key,
          snapshotMode = declarationMode declaration,
          snapshotEncoding = "consumer-json-cache",
          snapshotInvalidation = "tracked-by-mapped-wire-fingerprint",
          snapshotWireFingerprint = wireFingerprint graph (unMappedKey key),
          snapshotEnabled = aggregateHasSnapshot aggregate
        }
    | site@(RootRegister aggregate register key) <- persistedSites graph,
      Just declaration <- [Map.lookup key (tgDeclarations graph)]
    ]
  where
    aggregateHasSnapshot name =
      any
        (\case NAggregate aggregate -> aggName aggregate == name && maybe False (const True) (aggSnapshot aggregate); _ -> False)
        (specNodes spec)

jsonPathsFromDecl :: TypeGraph -> Set.Set MappedKey -> MappedKey -> [[PathSeg]]
jsonPathsFromDecl graph visited key
  | key `Set.member` visited = []
  | otherwise = case Map.lookup key (tgDeclarations 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 (rwfHaskell field) (rwfKey field) :) (jsonPathsFromExpr graph visited (rwfType field))
            | field <- fields
            ],
        onEnum = const [],
        onUnion = \_ arms ->
          concat
            [ map (SegArm (rwaCtor arm) (rwaTag arm) :) (maybe [] (jsonPathsFromExpr graph visited) (rwaPayload 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 :),
        onRef = \key -> map (SegDecl (unMappedKey key) :) (jsonPathsFromDecl graph visited key)
      }

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) . rootSurface) roots
          jsonCount = length (filter ((== surface) . jsonSurface) json)
       in CoverageCounts
            { totalRoots = length matching,
              structuralRoots = length (filter ((== StructuralCoverage) . rootMode) matching),
              opaqueRoots = length (filter ((== OpaqueCoverage) . rootMode) matching),
              jsonBoundaries = jsonCount
            }

opaqueSurfaceFindings :: [OpaqueBoundary] -> [CoverageFinding]
opaqueSurfaceFindings boundaries =
  [ CoverageFinding
      { findingSeverity = Warning,
        findingCode = CoverageOpaqueSurface,
        findingRoots = [root],
        findingMessage = "persisted mapped root contains opaque mapped boundaries"
      }
  | root <- Set.toAscList (Set.fromList (map opaqueRoot boundaries))
  ]

gateFinding :: Text -> [OpaqueBoundary] -> CoverageFinding
gateFinding message boundaries =
  CoverageFinding
    { findingSeverity = Error,
      findingCode = CoverageOpaqueGateExceeded,
      findingRoots = Set.toAscList (Set.fromList (map opaqueRoot boundaries)),
      findingMessage = message
    }

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

useSiteKey :: UseSite -> MappedKey
useSiteKey (RootCommandField _ _ _ key) = key
useSiteKey (RootEventField _ _ _ key) = key
useSiteKey (RootRegister _ _ key) = key
useSiteKey (RootWorkqueueField _ _ key) = key
useSiteKey (RootReadModelQueryInput _ key) = key
useSiteKey (RootReadModelQueryResult _ key) = key

useSiteSurface :: UseSite -> CoverageSurface
useSiteSurface RootCommandField {} = AggregateCommandPayload
useSiteSurface RootEventField {} = PrivateEventPayload
useSiteSurface RootRegister {} = SnapshotRegister
useSiteSurface RootWorkqueueField {} = WorkqueuePayload
useSiteSurface RootReadModelQueryInput {} = ReadModelQueryInput
useSiteSurface RootReadModelQueryResult {} = ReadModelQueryResult

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 :: UseSite -> Bool
isWireSite RootEventField {} = True
isWireSite RootWorkqueueField {} = True
isWireSite RootRegister {} = False
isWireSite RootCommandField {} = False
isWireSite RootReadModelQueryInput {} = False
isWireSite RootReadModelQueryResult {} = False

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

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 CoverageRoot where
  toJSON root =
    object
      [ "surface" .= rootSurface root,
        "consumer" .= rootConsumer root,
        "path" .= rootPath root,
        "mappedType" .= rootMappedType root,
        "mode" .= rootMode root,
        "canonicalType" .= rootCanonicalType root,
        "codecIdentity" .= rootCodecIdentity root,
        "codecVersion" .= rootCodecVersion root,
        "wireFingerprint" .= rootWireFingerprint root
      ]

instance ToJSON StructuralBoundary where
  toJSON boundary =
    object
      [ "root" .= structuralRoot boundary,
        "path" .= structuralPath boundary,
        "mappedType" .= structuralMappedType boundary,
        "canonicalType" .= structuralCanonicalType boundary,
        "wireFingerprint" .= structuralWireFingerprint boundary
      ]

instance ToJSON OpaqueBoundary where
  toJSON boundary =
    object
      [ "root" .= opaqueRoot boundary,
        "path" .= opaquePath boundary,
        "mappedType" .= opaqueMappedType boundary,
        "codecIdentity" .= opaqueCodecIdentity boundary,
        "codecVersion" .= opaqueCodecVersion boundary
      ]

instance ToJSON JsonBoundary where
  toJSON boundary = object ["surface" .= jsonSurface boundary, "root" .= jsonRoot boundary, "path" .= jsonPath boundary]

instance ToJSON SnapshotBoundary where
  toJSON boundary =
    object
      [ "root" .= snapshotRoot boundary,
        "aggregate" .= snapshotAggregate boundary,
        "register" .= snapshotRegister boundary,
        "mappedType" .= snapshotMappedType boundary,
        "mode" .= snapshotMode boundary,
        "snapshotEncoding" .= snapshotEncoding boundary,
        "invalidation" .= snapshotInvalidation boundary,
        "wireFingerprint" .= snapshotWireFingerprint boundary,
        "snapshotEnabled" .= snapshotEnabled boundary
      ]

instance ToJSON UnsupportedSurface where
  toJSON surface =
    object
      [ "surface" .= unsupportedSurface surface,
        "support" .= unsupportedSupport surface,
        "reason" .= unsupportedReason 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 (findingSeverity finding),
        "code" .= show (findingCode finding),
        "roots" .= findingRoots finding,
        "message" .= findingMessage 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" .= previousReference previous,
        "summary" .= previousSummary previous,
        "opaqueBoundaries" .= previousOpaqueBoundaries 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" .= coverageSpec report,
        "roots" .= coverageRoots report,
        "structuralBoundaries" .= coverageStructuralBoundaries report,
        "opaqueBoundaries" .= coverageOpaqueBoundaries report,
        "jsonBoundaries" .= coverageJsonBoundaries report,
        "snapshotBoundaries" .= coverageSnapshotBoundaries report,
        "unsupportedSurfaces" .= coverageUnsupportedSurfaces report,
        "summary" .= coverageSummary report,
        "findings" .= coverageFindings report,
        "previous" .= coveragePrevious report,
        "delta" .= coverageDelta report
      ]