CodecCompare.hs

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

-- | Pure historical-codec comparison and migration-evidence reports.
--
-- The comparison is deliberately finite evidence over typed fixture cases and
-- historical JSON goldens. It never changes which codec owns the wire schema and
-- never upgrades an opaque declaration to a structural claim.
module Keiro.Dsl.CodecCompare
  ( FixtureOrigin (..),
    DecodeOutcome (..),
    JsonPointer (..),
    ComparisonDifference (..),
    HistoricalCodec (..),
    CompareObservation (..),
    FixtureVerdict (..),
    CompareInputIssue (..),
    BranchKind (..),
    DeclaredBranch (..),
    ObservedBranch (..),
    CoverageGap (..),
    BranchSchema (..),
    BranchField (..),
    BranchArm (..),
    CompareProvenance (..),
    ClassifiedObservation (..),
    CompareReport (..),
    ReportWriteError (..),
    authorityStatement,
    canonicalJsonBytes,
    classifyObservation,
    declaredBranchesFor,
    observedBranchesFor,
    compareReport,
    renderCompareReport,
    reportSucceeded,
    writeCompareReportAtomic,
  )
where

import Control.Exception (IOException, bracketOnError, displayException, try)
import Control.Monad (when)
import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, withText, (.:), (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.RFC8785 qualified as RFC8785
import Data.Aeson.Types (Parser)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as LazyByteString
import Data.Foldable (toList)
import Data.List (sort)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), QualifiedValueName (..))
import Keiro.Dsl.Validate (DiagnosticCode (..))
import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile, renameFile)
import System.FilePath (takeDirectory, takeFileName)
import System.IO (Handle, hClose, openBinaryTempFile)

data FixtureOrigin = HistoricalGolden | FromBinding
  deriving stock (Eq, Ord, Show)

data DecodeOutcome
  = DecodedShape !Value
  | DecodeFailed !Text
  deriving stock (Eq, Show)

newtype JsonPointer = JsonPointer {unJsonPointer :: Text}
  deriving stock (Eq, Ord, Show)

data ComparisonDifference
  = EncodedValueDifference !JsonPointer !Value !Value
  | DecodedValueDifference !JsonPointer !Value !Value
  | GeneratedDecodeRejected !Text
  deriving stock (Eq, Show)

-- | A historical codec is an explicit value supplied by consumer-owned test
-- code. Its identity and version are report provenance, not dispatch keys.
data HistoricalCodec a = HistoricalCodec
  { hcIdentity :: !Text,
    hcVersion :: !Text,
    hcEncode :: !(a -> Value),
    hcDecode :: !(Value -> Either Text a)
  }

data CompareObservation
  = EncodeObservation
      { coCaseName :: !Text,
        coHistoricalValue :: !Value,
        coGeneratedValue :: !Value
      }
  | DecodeObservation
      { coFixturePath :: !FilePath,
        coInputValue :: !Value,
        coHistoricalDecode :: !DecodeOutcome,
        coGeneratedDecode :: !DecodeOutcome
      }
  deriving stock (Eq, Show)

data FixtureVerdict
  = JsonParity
  | RequiresVersionWork !ComparisonDifference
  deriving stock (Eq, Show)

data CompareInputIssue
  = HistoricalGoldenUnreadable !FilePath !Text
  | HistoricalCodecRejected !FilePath !Text
  | HistoricalCodecProvenanceInvalid !Text
  deriving stock (Eq, Show)

data BranchKind
  = UnionArm !Text
  | OptionalPresent
  | OptionalMissing
  | ExplicitNull
  deriving stock (Eq, Ord, Show)

data DeclaredBranch = DeclaredBranch
  { dbOrigin :: !FixtureOrigin,
    dbPointer :: !JsonPointer,
    dbKind :: !BranchKind
  }
  deriving stock (Eq, Ord, Show)

data ObservedBranch = ObservedBranch
  { obOrigin :: !FixtureOrigin,
    obPointer :: !JsonPointer,
    obKind :: !BranchKind
  }
  deriving stock (Eq, Ord, Show)

data CoverageGap = CoverageGap
  { cgOrigin :: !FixtureOrigin,
    cgPointer :: !JsonPointer,
    cgKind :: !BranchKind
  }
  deriving stock (Eq, Ord, Show)

-- | A codec-independent branch description embedded into generated
-- comparison runners. The generator constructs it through the checked type
-- graph's total algebras, so this module never has to interpret a consumer type.
data BranchSchema
  = BranchScalar
  | BranchOptional !BranchSchema
  | BranchList !BranchSchema
  | BranchMap !BranchSchema
  | BranchRecord ![BranchField]
  | BranchUnion !Text !Text ![BranchArm]
  deriving stock (Eq, Show)

data BranchField = BranchField
  { bfWireKey :: !Text,
    bfPresenceOptional :: !Bool,
    bfSchema :: !BranchSchema
  }
  deriving stock (Eq, Show)

data BranchArm = BranchArm
  { baWireTag :: !Text,
    baPayloadSchema :: !(Maybe BranchSchema)
  }
  deriving stock (Eq, Show)

data CompareProvenance = CompareProvenance
  { cpHistoricalCodecIdentity :: !Text,
    cpHistoricalCodecVersion :: !Text,
    cpCanonicalType :: !CanonicalTypeId,
    cpBindingSymbol :: !QualifiedValueName,
    cpBindingVersion :: !BindingVersion,
    cpWireFingerprint :: !Text
  }
  deriving stock (Eq, Show)

data ClassifiedObservation = ClassifiedObservation
  { classifiedOrigin :: !FixtureOrigin,
    classifiedName :: !Text,
    classifiedVerdict :: !FixtureVerdict
  }
  deriving stock (Eq, Show)

data CompareReport = CompareReport
  { crProvenance :: !CompareProvenance,
    crObservations :: ![ClassifiedObservation],
    crInputIssues :: ![CompareInputIssue],
    crCoverageGaps :: ![CoverageGap],
    crAuthority :: !Text
  }
  deriving stock (Eq, Show)

data ReportWriteError = ReportWriteError
  { reportWritePath :: !FilePath,
    reportWriteMessage :: !Text
  }
  deriving stock (Eq, Show)

authorityStatement :: Text
authorityStatement =
  "This comparison is MIGRATION EVIDENCE ONLY. After cutover the generated structural codec is the sole wire authority. This runner is never a runtime fallback and never upgrades an opaque declaration to structural. Resolve each difference with an explicit version bump and upcaster, or correct the declaration to match the historical wire contract; \"close enough\" is not an outcome."

-- | Render a JSON value in RFC 8785 canonical form.
canonicalJsonBytes :: Value -> ByteString
canonicalJsonBytes = LazyByteString.toStrict . RFC8785.encodeCanonical

classifyObservation :: CompareObservation -> Either CompareInputIssue FixtureVerdict
classifyObservation observation = case observation of
  EncodeObservation _ historical generated ->
    Right (classifyValues EncodedValueDifference historical generated)
  DecodeObservation fixturePath _ historical generated -> case historical of
    DecodeFailed reason -> Left (HistoricalCodecRejected fixturePath reason)
    DecodedShape historicalValue -> case generated of
      DecodeFailed reason -> Right (RequiresVersionWork (GeneratedDecodeRejected reason))
      DecodedShape generatedValue ->
        Right (classifyValues DecodedValueDifference historicalValue generatedValue)

classifyValues :: (JsonPointer -> Value -> Value -> ComparisonDifference) -> Value -> Value -> FixtureVerdict
classifyValues difference historical generated
  | canonicalJsonBytes historical == canonicalJsonBytes generated = JsonParity
  | otherwise = RequiresVersionWork (difference (firstDivergentPointer historical generated) historical generated)

compareReport ::
  CompareProvenance ->
  [CompareInputIssue] ->
  [CompareObservation] ->
  [DeclaredBranch] ->
  [ObservedBranch] ->
  CompareReport
compareReport provenance suppliedIssues observations declaredBranches observedBranches =
  CompareReport
    { crProvenance = provenance,
      crObservations = classified,
      crInputIssues = provenanceIssues provenance <> suppliedIssues <> classificationIssues,
      crCoverageGaps = coverageGaps declaredBranches observedBranches,
      crAuthority = authorityStatement
    }
  where
    outcomes = map classify observations
    classified = [value | Right value <- outcomes]
    classificationIssues = [issue | Left issue <- outcomes]

    classify observation = case classifyObservation observation of
      Left issue -> Left issue
      Right verdict ->
        Right
          ClassifiedObservation
            { classifiedOrigin = observationOrigin observation,
              classifiedName = observationName observation,
              classifiedVerdict = verdict
            }

observationOrigin :: CompareObservation -> FixtureOrigin
observationOrigin EncodeObservation {} = FromBinding
observationOrigin DecodeObservation {} = HistoricalGolden

observationName :: CompareObservation -> Text
observationName EncodeObservation {coCaseName = name} = name
observationName DecodeObservation {coFixturePath = path} = T.pack path

provenanceIssues :: CompareProvenance -> [CompareInputIssue]
provenanceIssues provenance =
  [ HistoricalCodecProvenanceInvalid "historical codec identity must not be blank"
  | T.null (T.strip (cpHistoricalCodecIdentity provenance))
  ]
    <> [ HistoricalCodecProvenanceInvalid "historical codec version must not be blank"
       | T.null (T.strip (cpHistoricalCodecVersion provenance))
       ]

coverageGaps :: [DeclaredBranch] -> [ObservedBranch] -> [CoverageGap]
coverageGaps declared observed =
  [ CoverageGap (dbOrigin branch) (dbPointer branch) (dbKind branch)
  | branch <- declared,
    branchKey branch `Set.notMember` observedKeys
  ]
  where
    observedKeys = Set.fromList (map observedBranchKey observed)
    branchKey branch = (dbOrigin branch, dbPointer branch, dbKind branch)
    observedBranchKey branch = (obOrigin branch, obPointer branch, obKind branch)

declaredBranchesFor :: FixtureOrigin -> BranchSchema -> [DeclaredBranch]
declaredBranchesFor origin = Set.toAscList . go ""
  where
    declared pointer kind = Set.singleton (DeclaredBranch origin (JsonPointer pointer) kind)
    go pointer schema = case schema of
      BranchScalar -> Set.empty
      BranchOptional nested ->
        declared pointer OptionalPresent
          <> declared pointer ExplicitNull
          <> go pointer nested
      BranchList nested -> go (appendPointer pointer "*") nested
      BranchMap nested -> go (appendPointer pointer "*") nested
      BranchRecord fields ->
        Set.unions
          [ presenceBranches pointer field <> go (appendPointer pointer (bfWireKey field)) (bfSchema field)
          | field <- fields
          ]
      BranchUnion _tagField contentsField arms ->
        Set.unions
          [ declared pointer (UnionArm (baWireTag arm))
              <> maybe Set.empty (go (appendPointer pointer contentsField)) (baPayloadSchema arm)
          | arm <- arms
          ]
    presenceBranches pointer field
      | bfPresenceOptional field =
          let fieldPointer = appendPointer pointer (bfWireKey field)
           in case origin of
                HistoricalGolden -> declared fieldPointer OptionalMissing <> declared fieldPointer OptionalPresent
                FromBinding -> declared fieldPointer OptionalPresent
      | otherwise = Set.empty

observedBranchesFor :: FixtureOrigin -> BranchSchema -> Value -> [ObservedBranch]
observedBranchesFor origin schema = Set.toAscList . go "" schema
  where
    observed pointer kind = Set.singleton (ObservedBranch origin (JsonPointer pointer) kind)
    go pointer branchSchema value = case branchSchema of
      BranchScalar -> Set.empty
      BranchOptional nested -> case value of
        Null -> observed pointer ExplicitNull
        _ -> observed pointer OptionalPresent <> go pointer nested value
      BranchList nested -> case value of
        Array values -> Set.unions [go (appendPointer pointer "*") nested item | item <- toList values]
        _ -> Set.empty
      BranchMap nested -> case value of
        Object values -> Set.unions [go (appendPointer pointer "*") nested item | item <- KeyMap.elems values]
        _ -> Set.empty
      BranchRecord fields -> case value of
        Object values -> Set.unions (map (observeField pointer values) fields)
        _ -> Set.empty
      BranchUnion tagField contentsField arms -> case value of
        Object values -> case KeyMap.lookup (Key.fromText tagField) values of
          Just (String tag) -> case filter ((== tag) . baWireTag) arms of
            arm : _ ->
              observed pointer (UnionArm tag)
                <> case (baPayloadSchema arm, KeyMap.lookup (Key.fromText contentsField) values) of
                  (Just nested, Just payload) -> go (appendPointer pointer contentsField) nested payload
                  _ -> Set.empty
            [] -> Set.empty
          _ -> Set.empty
        _ -> Set.empty
    observeField pointer values field =
      let fieldPointer = appendPointer pointer (bfWireKey field)
       in case KeyMap.lookup (Key.fromText (bfWireKey field)) values of
            Nothing
              | bfPresenceOptional field -> observed fieldPointer OptionalMissing
              | otherwise -> Set.empty
            Just fieldValue ->
              (if bfPresenceOptional field then observed fieldPointer OptionalPresent else Set.empty)
                <> go fieldPointer (bfSchema field) fieldValue

reportSucceeded :: CompareReport -> Bool
reportSucceeded report =
  null (crInputIssues report)
    && null (crCoverageGaps report)
    && all ((== JsonParity) . classifiedVerdict) (crObservations report)

renderCompareReport :: CompareReport -> Text
renderCompareReport report =
  T.unlines
    ( [ "codec comparison: "
          <> unCanonicalTypeId (cpCanonicalType provenance)
          <> " (binding-version \""
          <> unBindingVersion (cpBindingVersion provenance)
          <> "\")",
        "historical codec: \""
          <> cpHistoricalCodecIdentity provenance
          <> "\" version \""
          <> cpHistoricalCodecVersion provenance
          <> "\"",
        "observations: " <> tshow (length observations),
        "  encode parity: " <> ratio FromBinding,
        "  structural decode agreement: " <> ratio HistoricalGolden,
        "requires explicit version/upcaster work: " <> tshow (length differences) <> " observations  [" <> codeText CodecCompareDifference <> "]"
      ]
        <> concatMap renderDifference differences
        <> [ "input issues: " <> tshow (length (crInputIssues report)) <> "  [" <> codeText CodecCompareInvalidInput <> "]"
           ]
        <> map ("  " <>) (map renderInputIssue (crInputIssues report))
        <> [ "coverage gaps: " <> tshow (length (crCoverageGaps report)) <> "  [" <> codeText CodecCompareCoverageGap <> "]"
           ]
        <> map ("  " <>) (map renderCoverageGap (crCoverageGaps report))
        <> [ if reportSucceeded report
               then "result: PARITY"
               else "result: NOT PARITY — " <> tshow (length differences) <> " differences",
             crAuthority report
           ]
    )
  where
    provenance = crProvenance report
    observations = crObservations report
    differences = filter ((/= JsonParity) . classifiedVerdict) observations
    ratio origin =
      let matching = filter ((== origin) . classifiedOrigin) observations
          parityCount = length (filter ((== JsonParity) . classifiedVerdict) matching)
       in tshow parityCount <> "/" <> tshow (length matching) <> suffix origin
    suffix FromBinding = " (RFC 8785 canonical form)"
    suffix HistoricalGolden = ""

renderDifference :: ClassifiedObservation -> [Text]
renderDifference observation = case classifiedVerdict observation of
  JsonParity -> []
  RequiresVersionWork difference ->
    [ "  " <> classifiedName observation <> " [" <> direction <> "] at " <> pointerOf difference,
      "    " <> reasonOf difference
    ]
  where
    direction = case classifiedOrigin observation of
      FromBinding -> "encode"
      HistoricalGolden -> "decode"

renderInputIssue :: CompareInputIssue -> Text
renderInputIssue issue = case issue of
  HistoricalGoldenUnreadable path reason -> T.pack path <> ": unreadable historical golden: " <> reason
  HistoricalCodecRejected path reason -> T.pack path <> ": historical codec rejected its alleged golden: " <> reason
  HistoricalCodecProvenanceInvalid reason -> reason

renderCoverageGap :: CoverageGap -> Text
renderCoverageGap gap =
  originName (cgOrigin gap)
    <> " "
    <> renderPointer (cgPointer gap)
    <> ": "
    <> branchKindName (cgKind gap)

pointerOf :: ComparisonDifference -> Text
pointerOf difference = case difference of
  EncodedValueDifference pointer _ _ -> renderPointer pointer
  DecodedValueDifference pointer _ _ -> renderPointer pointer
  GeneratedDecodeRejected _ -> "<root>"

reasonOf :: ComparisonDifference -> Text
reasonOf difference = case difference of
  EncodedValueDifference _ historical generated ->
    "historical and generated encoders produced different JSON values: " <> valuePair historical generated
  DecodedValueDifference _ historical generated ->
    "historical and generated decoders normalized to different structural values: " <> valuePair historical generated
  GeneratedDecodeRejected reason -> "generated structural decoder rejected historical JSON: " <> reason

valuePair :: Value -> Value -> Text
valuePair historical generated = "historical=" <> tshow historical <> "; generated=" <> tshow generated

renderPointer :: JsonPointer -> Text
renderPointer (JsonPointer pointer)
  | T.null pointer = "<root>"
  | otherwise = pointer

writeCompareReportAtomic :: FilePath -> CompareReport -> IO (Either ReportWriteError ())
writeCompareReportAtomic path report = do
  let directory = takeDirectory path
      template = takeFileName path <> ".tmp"
  result <- try $ do
    createDirectoryIfMissing True directory
    bracketOnError
      (openBinaryTempFile directory template)
      cleanupTemporary
      ( \(temporary, handle) -> do
          LazyByteString.hPut handle (Aeson.encode report)
          hClose handle
          renameFile temporary path
      )
  pure $ case result of
    Left err -> Left (ReportWriteError path (T.pack (displayException (err :: IOException))))
    Right () -> Right ()

cleanupTemporary :: (FilePath, Handle) -> IO ()
cleanupTemporary (temporary, handle) = do
  _ <- try (hClose handle) :: IO (Either IOException ())
  exists <- doesFileExist temporary
  when exists (removeFile temporary)

firstDivergentPointer :: Value -> Value -> JsonPointer
firstDivergentPointer = go ""
  where
    go pointer (Object historical) (Object generated) =
      case firstDifferentKey historical generated of
        Nothing -> JsonPointer pointer
        Just key -> case (KeyMap.lookup (Key.fromText key) historical, KeyMap.lookup (Key.fromText key) generated) of
          (Just historicalValue, Just generatedValue) -> go (appendPointer pointer key) historicalValue generatedValue
          _ -> JsonPointer (appendPointer pointer key)
    go pointer (Array historical) (Array generated) =
      let historicalValues = toList historical
          generatedValues = toList generated
       in case firstDifferentIndex historicalValues generatedValues of
            Nothing -> JsonPointer pointer
            Just index -> case (indexMaybe index historicalValues, indexMaybe index generatedValues) of
              (Just historicalValue, Just generatedValue) -> go (appendPointer pointer (tshow index)) historicalValue generatedValue
              _ -> JsonPointer (appendPointer pointer (tshow index))
    go pointer _ _ = JsonPointer pointer

firstDifferentKey :: KeyMap.KeyMap Value -> KeyMap.KeyMap Value -> Maybe Text
firstDifferentKey historical generated =
  firstMatch differs allKeys
  where
    allKeys = sort (map Key.toText (KeyMap.keys historical <> KeyMap.keys generated))
    differs key = KeyMap.lookup (Key.fromText key) historical /= KeyMap.lookup (Key.fromText key) generated

firstDifferentIndex :: [Value] -> [Value] -> Maybe Int
firstDifferentIndex historical generated =
  firstMatch differs [0 .. max (length historical) (length generated) - 1]
  where
    differs index = indexMaybe index historical /= indexMaybe index generated

indexMaybe :: Int -> [a] -> Maybe a
indexMaybe index values = case drop index values of
  value : _ -> Just value
  [] -> Nothing

firstMatch :: (a -> Bool) -> [a] -> Maybe a
firstMatch predicate = \case
  [] -> Nothing
  value : rest
    | predicate value -> Just value
    | otherwise -> firstMatch predicate rest

appendPointer :: Text -> Text -> Text
appendPointer base segment = base <> "/" <> escapePointerSegment segment

escapePointerSegment :: Text -> Text
escapePointerSegment = T.replace "/" "~1" . T.replace "~" "~0"

tshow :: (Show a) => a -> Text
tshow = T.pack . show

codeText :: DiagnosticCode -> Text
codeText = T.pack . show

originName :: FixtureOrigin -> Text
originName HistoricalGolden = "historical-golden"
originName FromBinding = "typed-fixture"

parseOrigin :: Text -> Parser FixtureOrigin
parseOrigin "historical-golden" = pure HistoricalGolden
parseOrigin "typed-fixture" = pure FromBinding
parseOrigin value = fail ("unknown fixture origin: " <> T.unpack value)

branchKindName :: BranchKind -> Text
branchKindName kind = case kind of
  UnionArm arm -> "union-arm:" <> arm
  OptionalPresent -> "optional-present"
  OptionalMissing -> "optional-missing"
  ExplicitNull -> "explicit-null"

parseBranchKind :: Text -> Parser BranchKind
parseBranchKind value
  | Just arm <- T.stripPrefix "union-arm:" value = pure (UnionArm arm)
  | value == "optional-present" = pure OptionalPresent
  | value == "optional-missing" = pure OptionalMissing
  | value == "explicit-null" = pure ExplicitNull
  | otherwise = fail ("unknown branch kind: " <> T.unpack value)

instance ToJSON FixtureOrigin where
  toJSON = String . originName

instance FromJSON FixtureOrigin where
  parseJSON = withText "FixtureOrigin" parseOrigin

instance ToJSON JsonPointer where
  toJSON = String . unJsonPointer

instance FromJSON JsonPointer where
  parseJSON = withText "JsonPointer" (pure . JsonPointer)

instance ToJSON BranchKind where
  toJSON = String . branchKindName

instance FromJSON BranchKind where
  parseJSON = withText "BranchKind" parseBranchKind

instance ToJSON ComparisonDifference where
  toJSON difference = case difference of
    EncodedValueDifference pointer historical generated ->
      differenceObject "encoded-value-difference" pointer "encoder outputs differ" historical generated
    DecodedValueDifference pointer historical generated ->
      differenceObject "decoded-value-difference" pointer "normalized decoder outputs differ" historical generated
    GeneratedDecodeRejected reason ->
      object
        [ "kind" .= ("generated-decode-rejected" :: Text),
          "pointer" .= JsonPointer "",
          "reason" .= reason
        ]
    where
      differenceObject kind pointer reason historical generated =
        object
          [ "kind" .= (kind :: Text),
            "pointer" .= pointer,
            "reason" .= (reason :: Text),
            "historical" .= historical,
            "generated" .= generated
          ]

instance FromJSON ComparisonDifference where
  parseJSON = withObject "ComparisonDifference" $ \value -> do
    kind <- value .: "kind" :: Parser Text
    case kind of
      "encoded-value-difference" -> EncodedValueDifference <$> value .: "pointer" <*> value .: "historical" <*> value .: "generated"
      "decoded-value-difference" -> DecodedValueDifference <$> value .: "pointer" <*> value .: "historical" <*> value .: "generated"
      "generated-decode-rejected" -> GeneratedDecodeRejected <$> value .: "reason"
      _ -> fail ("unknown comparison difference: " <> T.unpack kind)

instance ToJSON FixtureVerdict where
  toJSON JsonParity = object ["verdict" .= ("json-parity" :: Text)]
  toJSON (RequiresVersionWork difference) =
    object
      [ "verdict" .= ("requires-version-work" :: Text),
        "code" .= codeText CodecCompareDifference,
        "difference" .= difference
      ]

instance FromJSON FixtureVerdict where
  parseJSON = withObject "FixtureVerdict" $ \value -> do
    verdict <- value .: "verdict" :: Parser Text
    case verdict of
      "json-parity" -> pure JsonParity
      "requires-version-work" -> RequiresVersionWork <$> value .: "difference"
      _ -> fail ("unknown fixture verdict: " <> T.unpack verdict)

instance ToJSON CompareInputIssue where
  toJSON issue = case issue of
    HistoricalGoldenUnreadable path reason -> issueObject "historical-golden-unreadable" path reason
    HistoricalCodecRejected path reason -> issueObject "historical-codec-rejected" path reason
    HistoricalCodecProvenanceInvalid reason ->
      object
        [ "code" .= codeText CodecCompareInvalidInput,
          "kind" .= ("historical-codec-provenance-invalid" :: Text),
          "reason" .= reason
        ]
    where
      issueObject kind path reason =
        object
          [ "code" .= codeText CodecCompareInvalidInput,
            "kind" .= (kind :: Text),
            "path" .= path,
            "reason" .= reason
          ]

instance FromJSON CompareInputIssue where
  parseJSON = withObject "CompareInputIssue" $ \value -> do
    kind <- value .: "kind" :: Parser Text
    case kind of
      "historical-golden-unreadable" -> HistoricalGoldenUnreadable <$> value .: "path" <*> value .: "reason"
      "historical-codec-rejected" -> HistoricalCodecRejected <$> value .: "path" <*> value .: "reason"
      "historical-codec-provenance-invalid" -> HistoricalCodecProvenanceInvalid <$> value .: "reason"
      _ -> fail ("unknown comparison input issue: " <> T.unpack kind)

instance ToJSON DeclaredBranch where
  toJSON branch =
    object
      [ "origin" .= dbOrigin branch,
        "pointer" .= dbPointer branch,
        "branch" .= dbKind branch
      ]

instance FromJSON DeclaredBranch where
  parseJSON = withObject "DeclaredBranch" $ \value ->
    DeclaredBranch <$> value .: "origin" <*> value .: "pointer" <*> value .: "branch"

instance ToJSON ObservedBranch where
  toJSON branch =
    object
      [ "origin" .= obOrigin branch,
        "pointer" .= obPointer branch,
        "branch" .= obKind branch
      ]

instance FromJSON ObservedBranch where
  parseJSON = withObject "ObservedBranch" $ \value ->
    ObservedBranch <$> value .: "origin" <*> value .: "pointer" <*> value .: "branch"

instance ToJSON CoverageGap where
  toJSON gap =
    object
      [ "code" .= codeText CodecCompareCoverageGap,
        "origin" .= cgOrigin gap,
        "pointer" .= cgPointer gap,
        "branch" .= cgKind gap
      ]

instance FromJSON CoverageGap where
  parseJSON = withObject "CoverageGap" $ \value ->
    CoverageGap <$> value .: "origin" <*> value .: "pointer" <*> value .: "branch"

instance ToJSON CompareProvenance where
  toJSON provenance =
    object
      [ "historicalCodecIdentity" .= cpHistoricalCodecIdentity provenance,
        "historicalCodecVersion" .= cpHistoricalCodecVersion provenance,
        "canonicalType" .= unCanonicalTypeId (cpCanonicalType provenance),
        "bindingSymbol" .= unQualifiedValueName (cpBindingSymbol provenance),
        "bindingVersion" .= unBindingVersion (cpBindingVersion provenance),
        "wireFingerprint" .= cpWireFingerprint provenance
      ]

instance FromJSON CompareProvenance where
  parseJSON = withObject "CompareProvenance" $ \value ->
    CompareProvenance
      <$> value .: "historicalCodecIdentity"
      <*> value .: "historicalCodecVersion"
      <*> (CanonicalTypeId <$> value .: "canonicalType")
      <*> (QualifiedValueName <$> value .: "bindingSymbol")
      <*> (BindingVersion <$> value .: "bindingVersion")
      <*> value .: "wireFingerprint"

instance ToJSON ClassifiedObservation where
  toJSON observation =
    object
      [ "origin" .= classifiedOrigin observation,
        "name" .= classifiedName observation,
        "result" .= classifiedVerdict observation
      ]

instance FromJSON ClassifiedObservation where
  parseJSON = withObject "ClassifiedObservation" $ \value ->
    ClassifiedObservation <$> value .: "origin" <*> value .: "name" <*> value .: "result"

instance ToJSON CompareReport where
  toJSON report =
    object
      [ "schema" .= ("keiro-dsl/codec-compare-report/1" :: Text),
        "authority" .= crAuthority report,
        "provenance" .= crProvenance report,
        "success" .= reportSucceeded report,
        "summary"
          .= object
            [ "observations" .= length (crObservations report),
              "parity" .= length (filter ((== JsonParity) . classifiedVerdict) (crObservations report)),
              "differences" .= length (filter ((/= JsonParity) . classifiedVerdict) (crObservations report)),
              "inputIssues" .= length (crInputIssues report),
              "coverageGaps" .= length (crCoverageGaps report)
            ],
        "observations" .= crObservations report,
        "inputIssues" .= crInputIssues report,
        "coverageGaps" .= crCoverageGaps report
      ]

instance FromJSON CompareReport where
  parseJSON = withObject "CompareReport" $ \value ->
    CompareReport
      <$> value .: "provenance"
      <*> value .: "observations"
      <*> value .: "inputIssues"
      <*> value .: "coverageGaps"
      <*> value .: "authority"