IdDomain.hs

-- | Semantic selection of the published ID runtime contract.
module Keiro.Dsl.IdDomain
  ( IdNormalization (..),
    IdDomainContract (..),
    IdDomainFailure (..),
    enforcedIdDomainVersion,
    idDomainContractFor,
    contractIdDomainContractFor,
    idDomainIdentity,
    idDomainIdentitiesForService,
    idDomainAcceptsText,
    validateIdDomainText,
    idDomainTextPattern,
    idDomainSampleText,
  )
where

import Data.Text (Text)
import Data.Text qualified as T
import Keiro.Codec.IdDomain
import Keiro.Dsl.Grammar (ContractEvent (..), ContractField (..), ContractNode (..), ContractType (..), IdDecl (..), Node (..), Spec (..))
import Keiro.Dsl.LanguageVersion (RuntimeCapability (..), runtimeProfileHasCapability)
import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract (..), checkedLanguageContract, checkedSpec)

-- | Versions 1 and 2 intentionally return 'Nothing': their generated IDs
-- admitted arbitrary text. Runtime-semantics generation 2 is the first
-- enforcing contract.
idDomainContractFor :: EffectiveLanguageContract -> Text -> Maybe IdDomainContract
idDomainContractFor languageContract prefix
  | runtimeProfileHasCapability ((.runtimeProfile) languageContract) GeneratedIdDomainTypeIdV7 =
      Just (typeIdV7Domain prefix)
  | otherwise = Nothing

-- | Public contract DTOs adopt the frozen TypeID-v7 admission contract only
-- in runtime semantics 3. Aggregate IDs retain the independent selector above.
contractIdDomainContractFor :: EffectiveLanguageContract -> Text -> Maybe IdDomainContract
contractIdDomainContractFor languageContract prefix
  | runtimeProfileHasCapability ((.runtimeProfile) languageContract) ContractIdDomainTypeIdV7 = Just (typeIdV7Domain prefix)
  | otherwise = Nothing

-- | Durable identity for the runtime admission domain of one declaration.
-- This is deliberately separate from nominal equality: IDs without equality
-- expressions still have a construction and codec contract.
idDomainIdentity :: Text -> IdDomainContract -> Text
idDomainIdentity name contract =
  T.intercalate
    "|"
    [ "id-domain",
      "name=" <> name,
      "contract=" <> idDomainVersion contract,
      "prefix=" <> idDomainPrefix contract,
      "separator=" <> T.singleton (idDomainSeparator contract),
      "json=" <> idDomainJsonRepresentation contract
    ]

idDomainIdentitiesForService :: CheckedService -> [Text]
idDomainIdentitiesForService service =
  aggregateIdentities <> contractIdentities
  where
    spec = checkedSpec service
    languageContract = checkedLanguageContract service
    aggregateIdentities =
      [ idDomainIdentity ((.name) declaration) contract
      | declaration <- (.ids) spec,
        Just contract <- [idDomainContractFor languageContract ((.prefix) declaration)]
      ]
    contractIdentities =
      [ idDomainIdentity ("contract:" <> (.name) contractNode <> "." <> (.name) event <> "." <> (.name) field) contract
      | NContract contractNode <- (.nodes) spec,
        event <- (.events) contractNode,
        field <- (.fields) event,
        CTypeId prefix <- [(.valueType) field],
        Just contract <- [contractIdDomainContractFor languageContract prefix]
      ]