keiro-dsl-0.6.0.0: src/Keiro/Dsl/MappedDiff.hs

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

-- | Recursive, wire-aware differences for consumer-owned mapped types.
--
-- This module deliberately returns mapped findings rather than importing the
-- ordinary 'Change' type: 'Keiro.Dsl.Diff' owns compatibility vectors and turns
-- each complete mapped use path into the appropriate event, snapshot, or build
-- finding. Keeping that seam acyclic also makes the recursive comparison usable
-- by mutation coverage without rendering a report.
module Keiro.Dsl.MappedDiff
  ( MappedFinding (..),
    diffMapped,
    renderMappedSubject,
  )
where

import Data.List (find, nubBy, sortOn)
import Data.Map.Strict qualified as Map
import Data.Maybe (isNothing)
import Data.Text (Text)
import Data.Text qualified as T
import Keiro.Dsl.Grammar
import Keiro.Dsl.TypeGraph
import Keiro.Dsl.Validate (DiagnosticCode (..))

data MappedFinding = MappedFinding
  { mfDeclaration :: !Name,
    mfLeaf :: !Text,
    mfCode :: !DiagnosticCode,
    mfDetail :: !Text,
    mfUsePaths :: ![UsePath],
    mfOldUnknownFields :: !(Maybe UnknownFields)
  }
  deriving stock (Eq, Show)

-- | Compare valid old/new mapped graphs. A spec that cannot resolve has
-- already failed @check@; the ordinary differ therefore emits no speculative
-- mapped compatibility claim for it.
diffMapped :: Spec -> Spec -> [MappedFinding]
diffMapped oldSpec newSpec = case (resolveTypeGraph oldSpec, resolveTypeGraph newSpec) of
  (Right oldGraph, Right newGraph) ->
    concatMap (uncurry (diffDeclaration oldGraph newGraph)) matched
      ++ map (addedDeclaration newGraph) added
      ++ map (removedDeclaration oldGraph) removed
    where
      oldDeclarations = tgDeclarations oldGraph
      newDeclarations = tgDeclarations newGraph
      matched =
        [ (oldDeclaration, newDeclaration)
        | (key, newDeclaration) <- Map.toList newDeclarations,
          oldDeclaration <- maybeToList (Map.lookup key oldDeclarations)
        ]
      added =
        [ (key, declaration)
        | (key, declaration) <- Map.toList newDeclarations,
          Map.notMember key oldDeclarations
        ]
      removed =
        [ (key, declaration)
        | (key, declaration) <- Map.toList oldDeclarations,
          Map.notMember key newDeclarations
        ]
  _ -> []

renderMappedSubject :: UsePath -> Text -> Text
renderMappedSubject path leaf =
  renderUsePath path <> if T.null leaf then "" else " " <> leaf

data DeclView
  = StructuralView !StructuralDecl !ShapeView
  | OpaqueView !OpaqueDecl

data ShapeView
  = RecordView !Name !UnknownFields ![ResolvedWireField]
  | EnumView ![WireEnum]
  | UnionView !UnionEncoding ![ResolvedWireArm]

data ExprView
  = ExprText
  | ExprInt
  | ExprInteger
  | ExprBool
  | ExprNatural
  | ExprTime
  | ExprJson
  | ExprOptional !ExprView
  | ExprList !ExprView
  | ExprMap !ExprView
  | ExprRef !MappedKey
  deriving stock (Eq, Show)

declView :: ResolvedMappedDecl -> DeclView
declView =
  foldMappedDecl
    MappedDeclAlgebra
      { onStructuralDecl = \declaration shape -> StructuralView declaration (shapeView shape),
        onOpaqueDecl = OpaqueView
      }

shapeView :: ResolvedMappedShape -> ShapeView
shapeView =
  foldMappedShape
    MappedShapeAlgebra
      { onRecord = RecordView,
        onEnum = EnumView,
        onUnion = UnionView
      }

exprView :: ResolvedTypeExpr -> ExprView
exprView =
  foldTypeExpr
    TypeExprAlgebra
      { onText = ExprText,
        onInt = ExprInt,
        onInteger = ExprInteger,
        onBool = ExprBool,
        onNatural = ExprNatural,
        onTime = ExprTime,
        onJson = ExprJson,
        onOptional = ExprOptional,
        onList = ExprList,
        onMap = ExprMap,
        onRef = ExprRef
      }

diffDeclaration :: TypeGraph -> TypeGraph -> ResolvedMappedDecl -> ResolvedMappedDecl -> [MappedFinding]
diffDeclaration oldGraph newGraph oldResolved newResolved =
  case (declView oldResolved, declView newResolved) of
    (StructuralView oldDeclaration oldShape, StructuralView newDeclaration newShape) ->
      metadataDiff paths oldDeclaration newDeclaration
        ++ diffShape paths name oldShape newShape
    (OpaqueView oldDeclaration, OpaqueView newDeclaration) ->
      opaqueMetadataDiff paths oldDeclaration newDeclaration
    _ ->
      [ finding
          paths
          name
          ""
          MappedModeCrossed
          "mapped declaration crossed the structural/opaque boundary; no structural proof can establish codec parity"
      ]
  where
    name = resolvedName newResolved
    paths = pathsFor oldGraph newGraph name

metadataDiff :: [UsePath] -> StructuralDecl -> StructuralDecl -> [MappedFinding]
metadataDiff paths oldDeclaration newDeclaration =
  [ finding
      paths
      name
      "haskell"
      MappedHaskellSourceChanged
      "consumer package, module, or type changed without changing declared wire identity; recompile every affected consumer"
  | sdHaskell oldDeclaration /= sdHaskell newDeclaration
  ]
    ++ [ finding
           paths
           name
           "binding"
           MappedBindingChanged
           "binding symbol or binding-version changed; diff cannot inspect binding behavior, so run the two-law, codec, and historical-fixture conformance suite"
       | (sdBinding oldDeclaration, sdBindingVersion oldDeclaration)
           /= (sdBinding newDeclaration, sdBindingVersion newDeclaration)
       ]
    ++ [ finding
           paths
           name
           "fixtures"
           MappedFixturesChanged
           "fixture evidence symbol changed; runtime wire policy is unchanged, but the complete conformance suite must run"
       | sdFixtures oldDeclaration /= sdFixtures newDeclaration
       ]
    ++ [ finding
           paths
           name
           "initial"
           MappedInitialChanged
           "mapped initial symbol changed; new streams and snapshot fingerprints may change while historical event decoding does not"
       | sdInitial oldDeclaration /= sdInitial newDeclaration
       ]
    ++ [ finding
           paths
           name
           "canonical-type"
           MappedCanonicalTypeChanged
           "canonical type identity changed; rebuild generated projections and invalidate mapped snapshots while declared event bytes remain unchanged"
       | sdCanonical oldDeclaration /= sdCanonical newDeclaration
       ]
  where
    name = sdName newDeclaration

opaqueMetadataDiff :: [UsePath] -> OpaqueDecl -> OpaqueDecl -> [MappedFinding]
opaqueMetadataDiff paths oldDeclaration newDeclaration =
  [ finding
      paths
      name
      "haskell"
      MappedHaskellSourceChanged
      "consumer package, module, or type changed without changing the opaque codec claim; recompile every affected consumer"
  | odHaskell oldDeclaration /= odHaskell newDeclaration
  ]
    ++ [ finding
           paths
           name
           "codec"
           MappedOpaqueCodecChanged
           "opaque codec identity or version changed; Keiro cannot inspect the codec and historical payload compatibility is unproven"
       | (odCodecIdentity oldDeclaration, odCodecVersion oldDeclaration)
           /= (odCodecIdentity newDeclaration, odCodecVersion newDeclaration)
       ]
    ++ [ finding
           paths
           name
           "fixtures"
           MappedFixturesChanged
           "fixture evidence symbol changed; runtime codec identity is unchanged, but the complete conformance suite must run"
       | odFixtures oldDeclaration /= odFixtures newDeclaration
       ]
    ++ [ finding
           paths
           name
           "initial"
           MappedInitialChanged
           "mapped initial symbol changed; new streams and snapshot fingerprints may change while historical event decoding does not"
       | odInitial oldDeclaration /= odInitial newDeclaration
       ]
  where
    name = odName newDeclaration

diffShape :: [UsePath] -> Name -> ShapeView -> ShapeView -> [MappedFinding]
diffShape paths declaration oldShape newShape = case (oldShape, newShape) of
  (RecordView oldConstructor oldUnknown oldFields, RecordView newConstructor newUnknown newFields) ->
    [ finding
        paths
        declaration
        "constructor"
        MappedRecordConstructorChanged
        "record constructor changed without changing the JSON wire identity; recompile affected consumers"
    | oldConstructor /= newConstructor
    ]
      ++ [ finding
             paths
             declaration
             "unknown-fields"
             MappedUnionEncodingChanged
             "record unknown-fields policy changed; historical and mixed-version decoding posture is no longer the same"
         | oldUnknown /= newUnknown
         ]
      ++ diffRecord paths declaration oldUnknown oldFields newFields
  (EnumView oldEntries, EnumView newEntries) -> diffEnum paths declaration oldEntries newEntries
  (UnionView oldEncoding oldArms, UnionView newEncoding newArms) ->
    [ finding
        paths
        declaration
        "encoding"
        MappedUnionEncodingChanged
        "tagged-object encoding changed; version and upcast every affected private event root"
    | oldEncoding /= newEncoding
    ]
      ++ diffUnion paths declaration oldArms newArms
  _ ->
    [ finding
        paths
        declaration
        "shape"
        MappedUnionEncodingChanged
        "structural shape kind changed; version and upcast every affected private event root"
    ]

diffRecord :: [UsePath] -> Name -> UnknownFields -> [ResolvedWireField] -> [ResolvedWireField] -> [MappedFinding]
diffRecord paths declaration oldUnknown oldFields newFields =
  concatMap (uncurry (diffField paths declaration)) matched
    ++ map addedFinding added
    ++ map removedFinding removed
  where
    (matched, added, removed) = pairFields oldFields newFields
    addedFinding field =
      (findingWithUnknown paths declaration (fieldLeaf field) code detail (Just oldUnknown))
      where
        hasDefault = isJustValue (rwfOnMissing field)
        code
          | hasDefault = MappedFieldAddedWithDefault
          | otherwise = MappedFieldAddedNoDefault
        oldPolicy = case oldUnknown of RejectUnknown -> "reject"; IgnoreUnknown -> "ignore"
        detail
          | hasDefault =
              "field added with an explicit on-missing default; new readers preserve old meaning, while old readers use unknown-fields="
                <> oldPolicy
          | otherwise =
              "field added without an on-missing default; old payloads do not contain it, so version and upcast every affected private event root"
    removedFinding field =
      finding
        paths
        declaration
        (fieldLeaf field)
        MappedFieldRemoved
        "field removed; replay-relevant removal remains breaking even when a tolerant decoder would ignore the historical key"

pairFields :: [ResolvedWireField] -> [ResolvedWireField] -> ([(ResolvedWireField, ResolvedWireField)], [ResolvedWireField], [ResolvedWireField])
pairFields oldFields newFields = (exact <> fallback, added, removed)
  where
    exact =
      [ (oldField, newField)
      | newField <- newFields,
        oldField <- maybeToList (find ((== rwfHaskell newField) . rwfHaskell) oldFields)
      ]
    matchedOld = map (rwfHaskell . fst) exact
    matchedNew = map (rwfHaskell . snd) exact
    unmatchedOld = [field | field <- oldFields, rwfHaskell field `notElem` matchedOld]
    unmatchedNew = [field | field <- newFields, rwfHaskell field `notElem` matchedNew]
    fallback =
      [ (oldField, newField)
      | newField <- unmatchedNew,
        oldField <- maybeToList (find ((== rwfKey newField) . rwfKey) unmatchedOld)
      ]
    fallbackOld = map (rwfHaskell . fst) fallback
    fallbackNew = map (rwfHaskell . snd) fallback
    removed = [field | field <- unmatchedOld, rwfHaskell field `notElem` fallbackOld]
    added = [field | field <- unmatchedNew, rwfHaskell field `notElem` fallbackNew]

diffField :: [UsePath] -> Name -> ResolvedWireField -> ResolvedWireField -> [MappedFinding]
diffField paths declaration oldField newField =
  [ finding
      paths
      declaration
      leaf
      MappedWireKeyChanged
      ("wire key changed '" <> rwfKey oldField <> "' -> '" <> rwfKey newField <> "'; version and upcast every affected private event root")
  | rwfKey oldField /= rwfKey newField
  ]
    ++ [ finding
           paths
           declaration
           leaf
           MappedPresenceChanged
           "field presence changed between required and optional; historical decode policy changed"
       | rwfPresence oldField /= rwfPresence newField
       ]
    ++ defaultChanges
    ++ diffExpr paths declaration (leaf <> ".type") (rwfType oldField) (rwfType newField)
  where
    leaf = fieldLeaf newField
    defaultChanges = case (rwfOnMissing oldField, rwfOnMissing newField) of
      (Just _, Nothing) ->
        [ finding
            paths
            declaration
            leaf
            MappedDefaultRemoved
            "on-missing default was removed; old payloads may no longer decode with preserved meaning"
        ]
      (oldDefault, newDefault)
        | oldDefault /= newDefault ->
            [ finding
                paths
                declaration
                leaf
                MappedDefaultChanged
                "on-missing default changed; the same historical bytes now construct a different consumer value"
            ]
      _ -> []

diffExpr :: [UsePath] -> Name -> Text -> ResolvedTypeExpr -> ResolvedTypeExpr -> [MappedFinding]
diffExpr paths declaration leaf oldExpression newExpression =
  case (exprView oldExpression, exprView newExpression) of
    (oldView, newView)
      | oldView == newView -> []
    (ExprOptional oldValue, ExprOptional newValue) -> recurse ".optional" oldValue newValue
    (ExprList oldValue, ExprList newValue) -> recurse "[]" oldValue newValue
    (ExprMap oldValue, ExprMap newValue) -> recurse "{}" oldValue newValue
    (ExprOptional _, _) -> nullability
    (_, ExprOptional _) -> nullability
    _ ->
      [ finding
          paths
          declaration
          leaf
          MappedFieldTypeChanged
          "wire type changed; version and upcast every affected private event root"
      ]
  where
    recurse suffix oldView newView = diffExprViews paths declaration (leaf <> suffix) oldView newView
    nullability =
      [ finding
          paths
          declaration
          leaf
          MappedNullabilityChanged
          "Optional nullability changed; historical null and non-null meanings are no longer stable"
      ]

diffExprViews :: [UsePath] -> Name -> Text -> ExprView -> ExprView -> [MappedFinding]
diffExprViews paths declaration leaf oldView newView = case (oldView, newView) of
  _ | oldView == newView -> []
  (ExprOptional oldValue, ExprOptional newValue) -> diffExprViews paths declaration (leaf <> ".optional") oldValue newValue
  (ExprList oldValue, ExprList newValue) -> diffExprViews paths declaration (leaf <> "[]") oldValue newValue
  (ExprMap oldValue, ExprMap newValue) -> diffExprViews paths declaration (leaf <> "{}") oldValue newValue
  (ExprOptional _, _) -> nullability
  (_, ExprOptional _) -> nullability
  _ -> [finding paths declaration leaf MappedFieldTypeChanged "wire type changed; version and upcast every affected private event root"]
  where
    nullability = [finding paths declaration leaf MappedNullabilityChanged "Optional nullability changed; historical null and non-null meanings are no longer stable"]

diffEnum :: [UsePath] -> Name -> [WireEnum] -> [WireEnum] -> [MappedFinding]
diffEnum paths declaration oldEntries newEntries =
  [ finding
      paths
      declaration
      (enumLeaf newEntry)
      MappedEnumSpellingChanged
      ("enum wire spelling changed '" <> weTag oldEntry <> "' -> '" <> weTag newEntry <> "'")
  | newEntry <- newEntries,
    oldEntry <- maybeToList (find ((== weCtor newEntry) . weCtor) oldEntries),
    weTag oldEntry /= weTag newEntry
  ]
    ++ [ finding
           paths
           declaration
           (enumLeaf entry)
           MappedEnumValueAdded
           "enum value added; existing history remains readable, but deploy readers before writers emit the new spelling; a future public surface exposing this closed enum would classify the addition as consumer-breaking"
       | entry <- newEntries,
         isNothing (find ((== weCtor entry) . weCtor) oldEntries)
       ]
    ++ [ finding
           paths
           declaration
           (enumLeaf entry)
           MappedEnumValueRemoved
           "enum value removed; historical payloads carrying its wire spelling no longer decode"
       | entry <- oldEntries,
         isNothing (find ((== weCtor entry) . weCtor) newEntries)
       ]

diffUnion :: [UsePath] -> Name -> [ResolvedWireArm] -> [ResolvedWireArm] -> [MappedFinding]
diffUnion paths declaration oldArms newArms =
  concatMap (uncurry pairedArm) matched
    ++ map addedArm added
    ++ map removedArm removed
  where
    (matched, added, removed) = pairArms oldArms newArms
    pairedArm oldArm newArm =
      [ finding
          paths
          declaration
          (armLeaf newArm)
          MappedArmTagChanged
          ("union arm tag changed '" <> rwaTag oldArm <> "' -> '" <> rwaTag newArm <> "'")
      | rwaTag oldArm /= rwaTag newArm
      ]
        ++ case (rwaPayload oldArm, rwaPayload newArm) of
          (Nothing, Nothing) -> []
          (Just oldPayload, Just newPayload) -> diffExpr paths declaration (armLeaf newArm <> ".payload") oldPayload newPayload
          _ -> [finding paths declaration (armLeaf newArm) MappedFieldTypeChanged "union arm payload presence changed; historical tagged objects no longer share one wire shape"]
    addedArm arm = finding paths declaration (armLeaf arm) MappedArmAdded "union arm added; existing history remains readable, but older binaries cannot read the new arm once emitted, so deploy readers before writers; a future public surface exposing this closed union would classify the addition as consumer-breaking"
    removedArm arm = finding paths declaration (armLeaf arm) MappedArmRemoved "union arm removed; historical tagged objects carrying that tag no longer decode"

pairArms :: [ResolvedWireArm] -> [ResolvedWireArm] -> ([(ResolvedWireArm, ResolvedWireArm)], [ResolvedWireArm], [ResolvedWireArm])
pairArms oldArms newArms = (exact <> fallback, added, removed)
  where
    exact =
      [ (oldArm, newArm)
      | newArm <- newArms,
        oldArm <- maybeToList (find ((== rwaCtor newArm) . rwaCtor) oldArms)
      ]
    matchedOld = map (rwaCtor . fst) exact
    matchedNew = map (rwaCtor . snd) exact
    unmatchedOld = [arm | arm <- oldArms, rwaCtor arm `notElem` matchedOld]
    unmatchedNew = [arm | arm <- newArms, rwaCtor arm `notElem` matchedNew]
    fallback =
      [ (oldArm, newArm)
      | newArm <- unmatchedNew,
        oldArm <- maybeToList (find ((== rwaTag newArm) . rwaTag) unmatchedOld)
      ]
    fallbackOld = map (rwaCtor . fst) fallback
    fallbackNew = map (rwaCtor . snd) fallback
    removed = [arm | arm <- unmatchedOld, rwaCtor arm `notElem` fallbackOld]
    added = [arm | arm <- unmatchedNew, rwaCtor arm `notElem` fallbackNew]

addedDeclaration :: TypeGraph -> (MappedKey, ResolvedMappedDecl) -> MappedFinding
addedDeclaration _ (key, _) =
  finding
    []
    (unMappedKey key)
    ""
    MappedDeclAdded
    "new mapped declaration; use-site changes retain their own compatibility classification"

removedDeclaration :: TypeGraph -> (MappedKey, ResolvedMappedDecl) -> MappedFinding
removedDeclaration graph (key, _) =
  finding
    (usePaths graph (unMappedKey key))
    (unMappedKey key)
    ""
    MappedDeclRemoved
    "mapped declaration removed; persisted roots using its historical decoder require migration, while an unused source-only declaration requires consumer rebuild only"

pathsFor :: TypeGraph -> TypeGraph -> Name -> [UsePath]
pathsFor oldGraph newGraph name =
  nubBy sameRendered . sortOn renderUsePath $ usePaths oldGraph name <> usePaths newGraph name
  where
    sameRendered left right = renderUsePath left == renderUsePath right

resolvedName :: ResolvedMappedDecl -> Name
resolvedName =
  foldMappedDecl
    MappedDeclAlgebra
      { onStructuralDecl = \declaration _ -> sdName declaration,
        onOpaqueDecl = odName
      }

fieldLeaf :: ResolvedWireField -> Text
fieldLeaf field = ".field " <> rwfHaskell field <> "[\"" <> rwfKey field <> "\"]"

armLeaf :: ResolvedWireArm -> Text
armLeaf arm = ".arm " <> rwaCtor arm <> "[\"" <> rwaTag arm <> "\"]"

enumLeaf :: WireEnum -> Text
enumLeaf entry = ".enum " <> weCtor entry <> "[\"" <> weTag entry <> "\"]"

finding :: [UsePath] -> Name -> Text -> DiagnosticCode -> Text -> MappedFinding
finding paths declaration leaf code detail =
  findingWithUnknown paths declaration leaf code detail Nothing

findingWithUnknown :: [UsePath] -> Name -> Text -> DiagnosticCode -> Text -> Maybe UnknownFields -> MappedFinding
findingWithUnknown paths declaration leaf code detail unknownFields =
  MappedFinding
    { mfDeclaration = declaration,
      mfLeaf = leaf,
      mfCode = code,
      mfDetail = detail,
      mfUsePaths = paths,
      mfOldUnknownFields = unknownFields
    }

isJustValue :: Maybe a -> Bool
isJustValue = not . isNothing

maybeToList :: Maybe a -> [a]
maybeToList = maybe [] pure