StructuralProjections.hs

{-# LANGUAGE TypeFamilies #-}
-- @generated by keiro-dsl 0.18.0.0 (language keiro-dsl 6) from context id-admission-domains mapped structural facade; do not edit.
-- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime.
-- Nominal ID and enum leaves carry exact canonical-text domains.
-- Int, Natural, and UTCTime belong to Keiki's ordered subset.
module Generated.IdAdmissionDomains.StructuralProjections
  ( identityEnvelopeLegacyIdWitness
  , identityEnvelopeLegacyIdGet
  , identityEnvelopeLegacyIdRawGet
  ) where

import Data.Text (Text)
import Data.List.NonEmpty qualified as NonEmpty
import Keiro.Codec.IdDomain (idDomainTextPattern, typeIdV5OrV7Domain)
import Keiro.Codec.Structural (bindingToShape, bindingFromShape, fixtureCases)
import Keiki.Core (FieldProjection (..), FieldWitness, ExactFieldProjection (..), exactFieldWitness)
import Keiki.ProjectionDomain (TextPattern, textProjectionDomain)
import Generated.IdAdmissionDomains.Structural.Shape.IdentityEnvelope (IdentityEnvelopeShape(legacyId))
import Conformance.IdAdmissionDomains.Bindings qualified as Bindings
import Conformance.IdAdmissionDomains.Domain (IdentityEnvelope)
import Generated.IdAdmissionDomains.Nominals qualified as Nominals
import Generated.IdAdmissionDomains.Structural.Shape.IdentityEnvelope qualified as ShapeIdentityEnvelope

identityEnvelopeLegacyIdProjectionDomainPattern :: TextPattern
identityEnvelopeLegacyIdProjectionDomainPattern = either (error . show) id (idDomainTextPattern (typeIdV5OrV7Domain "legacy"))

data IdentityEnvelopeLegacyIdProjection

identityEnvelopeLegacyIdRawGet :: IdentityEnvelope -> Nominals.LegacyId
identityEnvelopeLegacyIdRawGet owner = (bindingToShape Bindings.identityEnvelopeBinding owner).legacyId

identityEnvelopeLegacyIdGet :: IdentityEnvelope -> Text
identityEnvelopeLegacyIdGet owner = Nominals.legacyIdText (identityEnvelopeLegacyIdRawGet owner)

instance FieldProjection IdentityEnvelopeLegacyIdProjection where
  type FieldName IdentityEnvelopeLegacyIdProjection = "/legacyId"
  type FieldOwner IdentityEnvelopeLegacyIdProjection = IdentityEnvelope
  type FieldResult IdentityEnvelopeLegacyIdProjection = Text
  fieldShapeId _ = "conformance.id-admission-domains.IdentityEnvelope.v1"
  projectFieldValue _ = identityEnvelopeLegacyIdGet

instance ExactFieldProjection IdentityEnvelopeLegacyIdProjection where
  fieldProjectionDomain _ = textProjectionDomain identityEnvelopeLegacyIdProjectionDomainPattern
  reconstructFieldOwner _ value = do
    fieldValue <- either (const Nothing) Just (Nominals.parseLegacyId value)
    let baseShape = bindingToShape Bindings.identityEnvelopeBinding (snd (NonEmpty.head (fixtureCases Bindings.identityEnvelopeFixtures)))
    pure (bindingFromShape Bindings.identityEnvelopeBinding (case baseShape of ShapeIdentityEnvelope.IdentityEnvelope _ projectionField0_1 projectionField0_2 -> ShapeIdentityEnvelope.IdentityEnvelope fieldValue projectionField0_1 projectionField0_2))

identityEnvelopeLegacyIdWitness :: FieldWitness IdentityEnvelopeLegacyIdProjection
identityEnvelopeLegacyIdWitness = exactFieldWitness @IdentityEnvelopeLegacyIdProjection