okf-core 0.11.0.0 → 0.12.0.0

raw patch · 13 files changed

+2003/−2 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• okf-core.cabal +3/−1
• src/Okf/Profile/Sweep.hs +1432/−0
• test/Main.hs +363/−1
• test/fixtures/profile-discovery/dist-newstyle/valid-build-output.dhall +2/−0
• test/fixtures/sweep/accept/log.md +4/−0
• test/fixtures/sweep/accept/notes/first.md +11/−0
• test/fixtures/sweep/cases/expected.json +4/−0
• test/fixtures/sweep/cases/note-bad-status/notes/bad-status.md +11/−0
• test/fixtures/sweep/cases/note-missing-title/notes/missing-title.md +10/−0
• test/fixtures/sweep/classification.dhall +76/−0
• test/fixtures/sweep/closed.dhall +35/−0
• test/fixtures/sweep/profile.dhall +39/−0

@@ -7,6 +7,19 @@  ## [Unreleased] +## [0.12.0.0] - 2026-10-28++### Added++- `Okf.Profile.Sweep`: enumerate and apply relaxations of an authored+  `ProfileSpec`, load a sweep suite (acceptance bundles and `expected.json`+  cases in file order), check its baseline, and observe each relaxation's+  witnesses with the okf-profiles catalog's legacy predicate. `sweepProfile`+  classifies each relaxation by evidence and proof: `behaviourKey` proves+  inertness with documented erasures, composite policy units and+  `admitValue` relaxations cover what one relaxation alone cannot show, and+  `parseExceptions` reads a per-suite exception manifest.+ ## [0.11.0.0] - 2026-10-28  ### Added

@@ -1,6 +1,6 @@ cabal-version: 3.4 name: okf-core-version: 0.11.0.0+version: 0.12.0.0 synopsis:   Read, validate, index, and traverse Open Knowledge Format bundles @@ -27,6 +27,7 @@ extra-source-files:   dhall/**/*.dhall   test/fixtures/**/*.dhall+  test/fixtures/**/*.json   test/fixtures/**/*.md   test/fixtures/**/*.py   test/fixtures/**/*.sql@@ -73,6 +74,7 @@     Okf.Profile.Discovery     Okf.Profile.Documentation     Okf.Profile.Registry+    Okf.Profile.Sweep     Okf.Query     Okf.Trust     Okf.Validation

@@ -0,0 +1,1432 @@+-- | Load-bearing sweeps of a profile against its own test suite.+--+-- A profile catalog tests each descriptor with acceptance bundles that must pass+-- and rejection cases that must each fail for one reason. A /sweep/ asks the+-- converse question: weaken one rule one way (a /relaxation/), and does some+-- rejection case notice? A rule no case notices is not load-bearing, and the+-- suite has a gap.+--+-- The sweep relaxes the decoded 'ProfileSpec' in memory and recompiles it, per+-- [ADR 5](docs/adr/5-compile-profile-rules-before-validation.md): a relaxation+-- changes what the author wrote, and compilation decides what it means. Core+-- validation and log staleness do not depend on the profile, so every bundle is+-- loaded and checked once ('loadSuite', 'checkBaseline') and each relaxation+-- re-runs only the pure profile check ('observeRelaxation').+--+-- A case /meets its expectation/ under the predicate of the okf-profiles+-- catalog's @scripts\/profile_fixture_cases.py@: run without strict authoring, it+-- produces exactly the expected number of @profile: @ deviation lines and at+-- least one of them contains the expected field name. The predicate compares+-- rendered lines, and rendering belongs to the CLI, so the caller supplies the+-- renderer as a 'Render'.+module Okf.Profile.Sweep+  ( -- * Rule identity+    RuleScope (..),+    PresenceList (..),+    NestedContainer (..),+    RuleLocation (..),+    renderRuleLocation,++    -- * Relaxations+    RelaxationKind (..),+    TypeAttribute (..),+    KindSet (..),+    renderKindSet,+    parseKindSet,+    RelaxationTarget (..),+    Relaxation (..),+    relaxationId,+    relaxationField,+    relaxationKindName,+    legacyKindName,+    enumerateRelaxations,+    applyRelaxation,++    -- * Suites+    CaseExpectation (..),+    SuiteBundle (..),+    RejectionCase (..),+    Suite (..),+    SuiteError (..),+    loadSuite,+    parseExpectations,++    -- * Evaluation+    Render,+    BaselineFault (..),+    PreparedSuite,+    preparedSuite,+    preparedProfile,+    checkBaseline,+    planRelaxations,+    Observation (..),+    observeRelaxation,+    primaryWitness,+    legacyOutcome,+    compositeUnit,++    -- * Classification+    BehaviourKey,+    behaviourKey,+    withBehaviourKey,+    ExceptionClass (..),+    SweepException (..),+    loadExceptions,+    parseExceptions,+    Outcome (..),+    outcomeName,+    outcomeIsFailing,+    SweepResult (..),+    sweepProfile,+    staleExceptions,+  )+where++import Control.Exception (IOException, try)+import Data.Aeson qualified as Aeson+import Data.Aeson.Decoding.ByteString.Lazy (lbsToTokens)+import Data.Aeson.Decoding.Tokens (TkArray (..), TkRecord (..), Tokens (..))+import Data.Aeson.Key (Key)+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString.Lazy qualified as LazyBytes+import Data.Foldable (toList)+import Data.List qualified as List+import Data.Map.Lazy qualified as LazyMap+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (catMaybes, listToMaybe, mapMaybe)+import Data.Scientific (toBoundedInteger)+import Data.Text qualified as Text+import Okf.Bundle+  ( BundleError,+    BundleInventory,+    Concept,+    LogFile,+    conceptIdOf,+    conceptType,+    walkBundle,+    walkBundleInventory,+    walkLogs,+  )+import Okf.ConceptId (ConceptId)+import Okf.Index (OkfVersion, VersionDeclaration, readBundleVersion)+import Okf.Prelude hiding (List, Object)+import Okf.Profile+  ( Cardinality (..),+    CompiledProfile,+    EffectiveConceptConstraints,+    EffectiveFieldRule,+    FieldCondition,+    FieldFormat (DocumentHandle),+    FieldPath (..),+    FieldPathSegment (..),+    FieldRequirement,+    FieldRule,+    HandleReferenceRule,+    PathReferenceRule,+    ProfileDefinitionError,+    ProfileSpec,+    ProfileViolation (..),+    TypeRule,+    compileProfile,+    compiledProfileBaseConstraints,+    compiledProfileBaseRules,+    compiledProfileConstraintsForType,+    compiledProfileRequiredBundleVersion,+    compiledProfileRulesForType,+    compiledProfileSpec,+    compiledProfileTypeNames,+    fieldRuleAllowedValues,+    fieldRuleCardinality,+    fieldRuleDescription,+    fieldRuleElementAllowsUnknownFields,+    fieldRuleElementConstraints,+    fieldRuleElementFields,+    fieldRuleFormat,+    fieldRuleObjectAllowsUnknownFields,+    fieldRuleObjectConstraints,+    fieldRuleObjectFields,+    fieldRulePath,+    fieldRulePresenceClauses,+    fieldRuleReference,+    fieldRuleUniqueBy,+    presenceClauseCondition,+    presenceClauseRequirement,+    validateProfileVersion,+    validateProfileWith,+  )+import Okf.Validation+  ( BundleValidationError,+    LogStaleness,+    ValidationProfile (..),+    logStaleness,+    validateBundle,+    validateBundleLogs,+  )+import System.FilePath ((</>))++-- | Where a rule is declared: profile-wide, or under one concept type.+data RuleScope = ProfileScope | TypeScope !Text+  deriving stock (Generic, Eq, Ord, Show)++-- | Which presence list of a 'Okf.Profile.FrontmatterRules' or+-- 'Okf.Profile.NestedRules' holds the rule.+data PresenceList = RequiredList | RecommendedList | OptionalList+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++-- | The two nested record shapes a top-level rule can declare.+data NestedContainer = ElementFields | ObjectFields+  deriving stock (Generic, Eq, Ord, Show)++-- | One authored rule. 'Okf.Profile.compileProfile' rejects a field named twice+-- in one list at one scope, so scope, list and field identify a top-level rule,+-- and the optional nested part identifies a member of its element or object+-- record. Nested rules cannot nest further, so there are at most two levels.+data RuleLocation = RuleLocation+  { scope :: !RuleScope,+    list :: !PresenceList,+    field :: !Text,+    nested :: !(Maybe (NestedContainer, PresenceList, Text))+  }+  deriving stock (Generic, Eq, Ord, Show)++-- | @profile/required/status@, or+-- @type:Objective/required/keyResults/elementFields/required/id@.+renderRuleLocation :: RuleLocation -> Text+renderRuleLocation RuleLocation {scope, list = presenceList, field = fieldName, nested} =+  Text.intercalate "/" $+    [renderScope scope, renderPresenceList presenceList, fieldName]+      <> maybe [] (\(container, innerList, innerField) -> [renderContainer container, renderPresenceList innerList, innerField]) nested++renderScope :: RuleScope -> Text+renderScope = \case+  ProfileScope -> "profile"+  TypeScope typeName -> "type:" <> typeName++renderPresenceList :: PresenceList -> Text+renderPresenceList = \case+  RequiredList -> "required"+  RecommendedList -> "recommended"+  OptionalList -> "optional"++renderContainer :: NestedContainer -> Text+renderContainer = \case+  ElementFields -> "elementFields"+  ObjectFields -> "objectFields"++-- | A type-scope attribute that is not a frontmatter rule.+data TypeAttribute = PathPattern | ResourceScheme | RequireSchemaSection | SchemaColumns | IdPrefix+  deriving stock (Generic, Eq, Ord, Show)++-- | One way to weaken one rule. The first seven after 'Presence' are the kinds+-- the okf-profiles Python sweep generates ('legacyKindName').+data RelaxationKind+  = -- | remove the rule from its list+    Delete+  | -- | move a @required@ rule to @optional@ at the same scope, dropping only its+    -- @when@ gate, which governs presence alone+    Presence+  | -- | @allowedValues@ to @[]@, which means unconstrained+    ClearVocabulary+  | -- | append one value to a non-empty @allowedValues@+    AdmitValue !Text+  | DropFormat+  | DropUniqueBy+  | -- | @allowSelf@ from 'False' to 'True' inside a handle @reference@+    AllowSelf+  | -- | @allowLocal@ from 'False' to 'True' inside a handle @reference@+    AllowLocal+  | DropExternalUriPattern+  | DropCardinality+  | DropCondition+  | DropPath+  | DropReference+  | DropNested !NestedContainer+  | DropTypeAttribute !TypeAttribute+  | -- | composite unit: a list rule's cardinality to 'Any' and its+    -- @elementFields@ dropped together+    DropListShape+  | -- | composite unit: a type's @idPrefix@ and the @DocumentHandle@ format of+    -- its @idField@ rule dropped together+    DropHandleIdentity+  | -- | composite unit: a list rule's @uniqueBy@ dropped and its key member+    -- demoted to @optional@ together, which the descriptor cannot express one+    -- at a time+    DropUniqueKey+  deriving stock (Generic, Eq, Ord, Show)++-- | Which kinds a sweep enumerates. 'LegacyKinds' reproduces the Python sweep;+-- 'DefaultKinds' adds presence demotion; 'AllKinds' adds every other kind.+data KindSet = LegacyKinds | DefaultKinds | AllKinds+  deriving stock (Generic, Eq, Ord, Show)++renderKindSet :: KindSet -> Text+renderKindSet = \case+  LegacyKinds -> "legacy"+  DefaultKinds -> "default"+  AllKinds -> "all"++parseKindSet :: Text -> Maybe KindSet+parseKindSet = \case+  "legacy" -> Just LegacyKinds+  "default" -> Just DefaultKinds+  "all" -> Just AllKinds+  _ -> Nothing++-- | What a relaxation changes: one authored rule, or one type's attributes.+data RelaxationTarget = RuleTarget !RuleLocation | TypeTarget !Text+  deriving stock (Generic, Eq, Ord, Show)++data Relaxation = Relaxation+  { target :: !RelaxationTarget,+    kind :: !RelaxationKind+  }+  deriving stock (Generic, Eq, Ord, Show)++-- | The target followed by @#@ and the kind, such as+-- @type:Launch/required/launchRef#allowLocal@. Stable: exception manifests name+-- relaxations by it.+relaxationId :: Relaxation -> Text+relaxationId Relaxation {target, kind} = renderTarget target <> "#" <> relaxationKindName kind++renderTarget :: RelaxationTarget -> Text+renderTarget = \case+  RuleTarget location -> renderRuleLocation location+  TypeTarget typeName -> "type:" <> typeName++-- | The innermost field name the relaxation weakens, or the empty text for a+-- type attribute. This is the name the legacy case order prefers.+relaxationField :: Relaxation -> Text+relaxationField Relaxation {target} = case target of+  RuleTarget RuleLocation {field = fieldName, nested} ->+    maybe fieldName (\(_, _, innerField) -> innerField) nested+  TypeTarget _ -> ""++relaxationKindName :: RelaxationKind -> Text+relaxationKindName = \case+  Delete -> "delete"+  Presence -> "presence"+  ClearVocabulary -> "allowedValues"+  AdmitValue value -> "admitValue:" <> value+  DropFormat -> "format"+  DropUniqueBy -> "uniqueBy"+  AllowSelf -> "allowSelf"+  AllowLocal -> "allowLocal"+  DropExternalUriPattern -> "externalUriPattern"+  DropCardinality -> "cardinality"+  DropCondition -> "condition"+  DropPath -> "path"+  DropReference -> "reference"+  DropNested container -> renderContainer container+  DropTypeAttribute attribute -> case attribute of+    PathPattern -> "pathPattern"+    ResourceScheme -> "resourceScheme"+    RequireSchemaSection -> "requireSchemaSection"+    SchemaColumns -> "schemaColumns"+    IdPrefix -> "idPrefix"+  DropListShape -> "listShape"+  DropHandleIdentity -> "handleIdentity"+  DropUniqueKey -> "uniqueKey"++-- | The kind string the Python sweep prints, when the kind is one it generates.+legacyKindName :: RelaxationKind -> Maybe Text+legacyKindName kind = case kind of+  Delete -> Just (relaxationKindName kind)+  ClearVocabulary -> Just (relaxationKindName kind)+  DropFormat -> Just (relaxationKindName kind)+  DropUniqueBy -> Just (relaxationKindName kind)+  AllowSelf -> Just (relaxationKindName kind)+  AllowLocal -> Just (relaxationKindName kind)+  DropExternalUriPattern -> Just (relaxationKindName kind)+  _ -> Nothing++-- | Every applicable relaxation of the authored descriptor, in declaration+-- order: profile-wide rules, then each type's rules followed by its attributes;+-- within one scope the @required@, @recommended@ and @optional@ lists in turn;+-- and within one rule its own relaxations before those of its nested members.+--+-- The legacy kinds follow the Python sweep's applicability: @allowedValues@+-- only when non-empty, @format@ and @uniqueBy@ only when set, @allowSelf@ and+-- @allowLocal@ only when 'False' inside a handle @reference@ (never a @path@),+-- @externalUriPattern@ only when set, and @delete@ always. Unlike the Python+-- sweep, a rule that is the sole element of its list can be deleted.+enumerateRelaxations :: KindSet -> ProfileSpec -> [Relaxation]+enumerateRelaxations kinds spec =+  scopeRelaxations kinds ProfileScope (spec ^. #frontmatter . #required) (spec ^. #frontmatter . #recommended) (spec ^. #frontmatter . #optional)+    <> concat+      [ scopeRelaxations kinds (TypeScope (rule ^. #type_)) (rule ^. #frontmatter . #required) (rule ^. #frontmatter . #recommended) (rule ^. #frontmatter . #optional)+          <> typeRelaxations kinds rule+      | rule <- spec ^. #types+      ]++scopeRelaxations :: KindSet -> RuleScope -> [FieldRule] -> [FieldRule] -> [FieldRule] -> [Relaxation]+scopeRelaxations kinds scope required recommended optional =+  concat+    [ fieldRuleRelaxations kinds (RuleLocation scope presenceList (rule ^. #field) Nothing) rule+    | (presenceList, rules) <- [(RequiredList, required), (RecommendedList, recommended), (OptionalList, optional)],+      rule <- rules+    ]++fieldRuleRelaxations :: KindSet -> RuleLocation -> FieldRule -> [Relaxation]+fieldRuleRelaxations kinds location rule =+  map (Relaxation (RuleTarget location)) (ruleKinds kinds (location ^. #list) facts)+    <> nestedRelaxations ElementFields (rule ^. #elementFields)+    <> nestedRelaxations ObjectFields (rule ^. #objectFields)+  where+    facts =+      RuleFacts+        { allowedValues = rule ^. #allowedValues,+          cardinality = rule ^. #cardinality,+          format = rule ^. #format,+          reference = rule ^. #reference,+          path = rule ^. #path,+          condition = rule ^. #when,+          uniqueBy = rule ^. #uniqueBy,+          hasElementFields = isJust (rule ^. #elementFields),+          hasObjectFields = isJust (rule ^. #objectFields)+        }+    nestedRelaxations container = \case+      Nothing -> []+      Just nestedRules ->+        concat+          [ map+              (Relaxation (RuleTarget (location & #nested ?~ (container, presenceList, member ^. #field))))+              ( ruleKinds+                  kinds+                  presenceList+                  RuleFacts+                    { allowedValues = member ^. #allowedValues,+                      cardinality = member ^. #cardinality,+                      format = member ^. #format,+                      reference = member ^. #reference,+                      path = member ^. #path,+                      condition = member ^. #when,+                      uniqueBy = Nothing,+                      hasElementFields = False,+                      hasObjectFields = False+                    }+              )+          | (presenceList, members) <-+              [ (RequiredList, nestedRules ^. #required),+                (RecommendedList, nestedRules ^. #recommended),+                (OptionalList, nestedRules ^. #optional)+              ],+            member <- members+          ]++-- | What enumeration needs to know about one rule, top-level or nested.+data RuleFacts = RuleFacts+  { allowedValues :: ![Text],+    cardinality :: !Cardinality,+    format :: !(Maybe FieldFormat),+    reference :: !(Maybe HandleReferenceRule),+    path :: !(Maybe PathReferenceRule),+    condition :: !(Maybe FieldCondition),+    uniqueBy :: !(Maybe Text),+    hasElementFields :: !Bool,+    hasObjectFields :: !Bool+  }+  deriving stock (Generic)++ruleKinds :: KindSet -> PresenceList -> RuleFacts -> [RelaxationKind]+ruleKinds kinds presenceList facts =+  catMaybes+    [ Just Delete,+      Presence <$ guard' (kinds /= LegacyKinds && presenceList == RequiredList),+      ClearVocabulary <$ guard' (not (null (facts ^. #allowedValues))),+      DropFormat <$ facts ^. #format,+      DropUniqueBy <$ facts ^. #uniqueBy,+      AllowSelf <$ guard' (any (not . (^. #allowSelf)) (facts ^. #reference)),+      AllowLocal <$ guard' (any (not . (^. #allowLocal)) (facts ^. #reference)),+      DropExternalUriPattern <$ (facts ^. #reference >>= (^. #externalUriPattern))+    ]+    <> if kinds /= AllKinds+      then []+      else+        catMaybes+          [ DropCardinality <$ guard' (facts ^. #cardinality /= Any),+            DropCondition <$ facts ^. #condition,+            DropPath <$ facts ^. #path,+            DropReference <$ facts ^. #reference,+            DropNested ElementFields <$ guard' (facts ^. #hasElementFields),+            DropNested ObjectFields <$ guard' (facts ^. #hasObjectFields)+          ]++typeRelaxations :: KindSet -> TypeRule -> [Relaxation]+typeRelaxations kinds rule+  | kinds /= AllKinds = []+  | otherwise =+      map (Relaxation (TypeTarget (rule ^. #type_)) . DropTypeAttribute) . catMaybes $+        [ PathPattern <$ rule ^. #pathPattern,+          ResourceScheme <$ rule ^. #resourceScheme,+          RequireSchemaSection <$ guard' (rule ^. #requireSchemaSection),+          SchemaColumns <$ guard' (not (null (rule ^. #schemaColumns))),+          IdPrefix <$ rule ^. #idPrefix+        ]++guard' :: Bool -> Maybe ()+guard' condition = if condition then Just () else Nothing++-- | Perform one relaxation on the authored descriptor. A relaxation whose target+-- does not exist leaves the descriptor unchanged.+applyRelaxation :: Relaxation -> ProfileSpec -> ProfileSpec+applyRelaxation Relaxation {target, kind} spec = case target of+  TypeTarget typeName+    | kind == DropHandleIdentity ->+        spec+          & #types+          . traverse+          . filtered ((== typeName) . (^. #type_))+          %~ \rule ->+            rule+              & #idPrefix+              .~ Nothing+              & #frontmatter+              %~ dropHandleFormat+    | otherwise ->+        spec & #types . traverse . filtered ((== typeName) . (^. #type_)) %~ relaxTypeRule kind+  RuleTarget location@RuleLocation {scope} -> case scope of+    ProfileScope -> spec & #frontmatter %~ relaxScope location kind+    TypeScope typeName ->+      spec & #types . traverse . filtered ((== typeName) . (^. #type_)) . #frontmatter %~ relaxScope location kind+  where+    dropHandleFormat rules = case spec ^. #idField of+      Nothing -> rules+      Just idField ->+        foldr+          (\presenceList -> presenceListOf presenceList . traverse . filtered (named idField) . #format %~ dropHandle)+          rules+          [RequiredList, RecommendedList, OptionalList]+    dropHandle = \case+      Just (DocumentHandle _) -> Nothing+      other -> other++relaxScope ::+  ( HasField' "required" rules [FieldRule],+    HasField' "recommended" rules [FieldRule],+    HasField' "optional" rules [FieldRule]+  ) =>+  RuleLocation ->+  RelaxationKind ->+  rules ->+  rules+relaxScope RuleLocation {list = presenceList, field = fieldName, nested} kind rules = case nested of+  Nothing -> relaxInList presenceList fieldName kind relaxFieldRule rules+  Just (container, innerList, innerField)+    | kind == DropUniqueKey ->+        rules+          & presenceListOf presenceList+          . traverse+          . filtered (named fieldName)+          %~ \rule ->+            rule+              & #uniqueBy+              .~ Nothing+              & containerOf container+              . _Just+              %~ relaxInList innerList innerField Presence relaxCommon+    | otherwise ->+        rules+          & presenceListOf presenceList+          . traverse+          . filtered (named fieldName)+          . containerOf container+          . _Just+          %~ relaxInList innerList innerField kind relaxCommon+  where+    containerOf = \case+      ElementFields -> #elementFields+      ObjectFields -> #objectFields++relaxInList ::+  ( HasField' "required" rules [rule],+    HasField' "recommended" rules [rule],+    HasField' "optional" rules [rule],+    HasField' "field" rule Text,+    HasField' "when" rule (Maybe FieldCondition)+  ) =>+  PresenceList ->+  Text ->+  RelaxationKind ->+  (RelaxationKind -> rule -> rule) ->+  rules ->+  rules+relaxInList presenceList fieldName kind relaxOne rules = case kind of+  Delete -> rules & presenceListOf presenceList %~ filter (not . named fieldName)+  Presence+    | presenceList == RequiredList ->+        let demoted = [rule & field' @"when" .~ Nothing | rule <- rules ^. presenceListOf presenceList, named fieldName rule]+         in rules+              & presenceListOf presenceList+              %~ filter (not . named fieldName)+              & presenceListOf OptionalList+              %~ (<> demoted)+    | otherwise -> rules+  _ -> rules & presenceListOf presenceList . traverse . filtered (named fieldName) %~ relaxOne kind++presenceListOf ::+  ( HasField' "required" rules [rule],+    HasField' "recommended" rules [rule],+    HasField' "optional" rules [rule]+  ) =>+  PresenceList ->+  Lens' rules [rule]+presenceListOf = \case+  RequiredList -> field' @"required"+  RecommendedList -> field' @"recommended"+  OptionalList -> field' @"optional"++named :: (HasField' "field" rule Text) => Text -> rule -> Bool+named fieldName rule = rule ^. field' @"field" == fieldName++relaxFieldRule :: RelaxationKind -> FieldRule -> FieldRule+relaxFieldRule kind rule = case kind of+  DropUniqueBy -> rule & #uniqueBy .~ Nothing+  DropNested ElementFields -> rule & #elementFields .~ Nothing+  DropNested ObjectFields -> rule & #objectFields .~ Nothing+  DropListShape -> rule & #cardinality .~ Any & #elementFields .~ Nothing+  _ -> relaxCommon kind rule++-- | The relaxations a top-level 'FieldRule' and a nested+-- 'Okf.Profile.NestedFieldRule' share.+relaxCommon ::+  ( HasField' "allowedValues" rule [Text],+    HasField' "cardinality" rule Cardinality,+    HasField' "format" rule (Maybe FieldFormat),+    HasField' "reference" rule (Maybe HandleReferenceRule),+    HasField' "path" rule (Maybe PathReferenceRule),+    HasField' "when" rule (Maybe FieldCondition)+  ) =>+  RelaxationKind ->+  rule ->+  rule+relaxCommon kind rule = case kind of+  ClearVocabulary -> rule & field' @"allowedValues" .~ []+  AdmitValue value -> rule & field' @"allowedValues" %~ (<> [value])+  DropFormat -> rule & field' @"format" .~ Nothing+  AllowSelf -> rule & field' @"reference" . _Just . #allowSelf .~ True+  AllowLocal -> rule & field' @"reference" . _Just . #allowLocal .~ True+  DropExternalUriPattern -> rule & field' @"reference" . _Just . #externalUriPattern .~ Nothing+  DropCardinality -> rule & field' @"cardinality" .~ Any+  DropCondition -> rule & field' @"when" .~ Nothing+  DropPath -> rule & field' @"path" .~ Nothing+  DropReference -> rule & field' @"reference" .~ Nothing+  _ -> rule++relaxTypeRule :: RelaxationKind -> TypeRule -> TypeRule+relaxTypeRule kind rule = case kind of+  DropTypeAttribute PathPattern -> rule & #pathPattern .~ Nothing+  DropTypeAttribute ResourceScheme -> rule & #resourceScheme .~ Nothing+  DropTypeAttribute RequireSchemaSection -> rule & #requireSchemaSection .~ False+  DropTypeAttribute SchemaColumns -> rule & #schemaColumns .~ []+  DropTypeAttribute IdPrefix -> rule & #idPrefix .~ Nothing+  _ -> rule++-- | What one rejection case must produce: @count@ deviation lines, at least one+-- of which contains @field@.+data CaseExpectation = CaseExpectation+  { field :: !Text,+    count :: !Int+  }+  deriving stock (Generic, Eq, Show)++-- | One bundle, loaded once: its concepts, file inventory, version declaration+-- and logs.+data SuiteBundle = SuiteBundle+  { path :: !FilePath,+    concepts :: ![Concept],+    inventory :: !BundleInventory,+    declaration :: !VersionDeclaration,+    logs :: ![LogFile]+  }+  deriving stock (Generic)++data RejectionCase = RejectionCase+  { name :: !Text,+    expectation :: !CaseExpectation,+    bundle :: !SuiteBundle+  }+  deriving stock (Generic)++-- | The acceptance bundles and the rejection cases, the cases in the order+-- @expected.json@ lists them.+data Suite = Suite+  { acceptance :: ![SuiteBundle],+    cases :: ![RejectionCase]+  }+  deriving stock (Generic)++data SuiteError+  = -- | a bundle could not be walked or its version declaration read+    SuiteBundleError !FilePath !BundleError+  | -- | @expected.json@ is missing or malformed (path, reason)+    ExpectationsError !FilePath !Text+  deriving stock (Generic, Eq, Show)++-- | Load the acceptance bundles and the cases directory. The cases are the+-- subdirectories @expected.json@ names, in the order it names them; a+-- subdirectory it does not name is not a case.+loadSuite :: [FilePath] -> FilePath -> IO (Either SuiteError Suite)+loadSuite acceptPaths casesDir = do+  let expectedPath = casesDir </> "expected.json"+  read' <- try (LazyBytes.readFile expectedPath)+  case read' of+    Left (readError :: IOException) -> pure (Left (ExpectationsError expectedPath (Text.pack (show readError))))+    Right bytes -> case parseExpectations bytes of+      Left reason -> pure (Left (ExpectationsError expectedPath reason))+      Right expectations -> do+        accepted <- traverse loadSuiteBundle acceptPaths+        rejected <-+          for expectations $ \(caseName, expectation) ->+            fmap (RejectionCase caseName expectation) <$> loadSuiteBundle (casesDir </> Text.unpack caseName)+        pure (Suite <$> sequence accepted <*> sequence rejected)++loadSuiteBundle :: FilePath -> IO (Either SuiteError SuiteBundle)+loadSuiteBundle bundlePath = do+  concepts <- walkBundle bundlePath+  inventory <- walkBundleInventory bundlePath+  declaration <- readBundleVersion bundlePath+  logs <- walkLogs bundlePath+  pure . first (SuiteBundleError bundlePath) $+    SuiteBundle bundlePath <$> concepts <*> inventory <*> declaration <*> logs++-- | Read @expected.json@: an object mapping each case name either to the field+-- name its diagnostic must contain, or to @{"field": …, "diagnostics": N}@.+--+-- Aeson's object type does not keep key order, and the legacy witness is the+-- first case that notices, so the order is read from the token stream and the+-- values from the decoded object. A repeated key keeps its first position.+parseExpectations :: LazyBytes.ByteString -> Either Text [(Text, CaseExpectation)]+parseExpectations bytes = do+  value <- first Text.pack (Aeson.eitherDecode bytes)+  entries <- case value of+    Aeson.Object entries -> Right entries+    _ -> Left "expected a JSON object mapping case names to expectations"+  order <- first Text.pack (topLevelKeys (lbsToTokens bytes))+  for (List.nub order) $ \key ->+    let caseName = Key.toText key+     in case KeyMap.lookup key entries of+          Just (String fieldName) -> Right (caseName, CaseExpectation fieldName 1)+          Just (Aeson.Object spec)+            | Just (String fieldName) <- KeyMap.lookup "field" spec,+              Just (Number diagnostics) <- KeyMap.lookup "diagnostics" spec,+              Just count <- toBoundedInteger diagnostics,+              count >= 0 ->+                Right (caseName, CaseExpectation fieldName count)+          _ ->+            Left+              ( "case "+                  <> caseName+                  <> ": expected a field name or {\"field\": …, \"diagnostics\": N}"+              )++topLevelKeys :: Tokens k String -> Either String [Key]+topLevelKeys = \case+  TkRecordOpen record -> keysOf record+  TkErr err -> Left err+  _ -> Left "expected a JSON object"+  where+    keysOf = \case+      TkPair key value -> (key :) <$> (skipValue value >>= keysOf)+      TkRecordEnd _ -> Right []+      TkRecordErr err -> Left err++-- | Skip one JSON value in a token stream, returning what follows it.+skipValue :: Tokens k String -> Either String k+skipValue = \case+  TkLit _ rest -> Right rest+  TkText _ rest -> Right rest+  TkNumber _ rest -> Right rest+  TkArrayOpen items -> skipItems items+  TkRecordOpen pairs -> skipPairs pairs+  TkErr err -> Left err+  where+    skipItems = \case+      TkItem value -> skipValue value >>= skipItems+      TkArrayEnd rest -> Right rest+      TkArrayErr err -> Left err+    skipPairs = \case+      TkPair _ value -> skipValue value >>= skipPairs+      TkRecordEnd rest -> Right rest+      TkRecordErr err -> Left err++-- | How the CLI renders one deviation, given the compiled profile it came from+-- and the bundle's concepts.+type Render = CompiledProfile -> [Concept] -> ProfileViolation -> Text++-- | Why a sweep cannot start: the unrelaxed profile and suite disagree.+data BaselineFault+  = -- | an acceptance bundle fails core validation or has stale logs, which no+    -- relaxation can change+    AcceptanceCoreInvalid !FilePath ![BundleValidationError] ![LogStaleness]+  | -- | an acceptance bundle deviates from the unrelaxed profile (rendered lines)+    AcceptanceProfileDeviations !FilePath ![Text]+  | -- | a case does not meet its expectation under the unrelaxed profile+    -- (case, expectation, rendered deviation lines)+    CaseExpectationUnmet !Text !CaseExpectation ![Text]+  deriving stock (Generic, Eq, Show)++-- | A suite whose baseline holds, with what every relaxation is compared to.+data PreparedSuite = PreparedSuite+  { suite :: !Suite,+    render :: !Render,+    baseline :: !CompiledProfile,+    -- | each case's violations under the unrelaxed profile, in case order+    baselineViolations :: ![[ProfileViolation]],+    keyOf :: !(CompiledProfile -> BehaviourKey),+    baselineKey :: !BehaviourKey+  }+  deriving stock (Generic)++preparedSuite :: PreparedSuite -> Suite+preparedSuite prepared = prepared ^. #suite++preparedProfile :: PreparedSuite -> CompiledProfile+preparedProfile prepared = prepared ^. #baseline++-- | Replace the behaviour key a prepared suite proves inertness with. For tests+-- of the inertness contradiction only: a key that erases too much makes a+-- relaxation that some case notices look inert.+withBehaviourKey :: (CompiledProfile -> BehaviourKey) -> PreparedSuite -> PreparedSuite+withBehaviourKey keyFunction prepared =+  prepared & #keyOf .~ keyFunction & #baselineKey .~ keyFunction (prepared ^. #baseline)++-- | Check the unrelaxed profile against the suite: every acceptance bundle+-- passes as @okf validate --strict --profile-enforce --log-enforce@ decides, and+-- every case meets its expectation. Reports every fault, not only the first.+checkBaseline :: Render -> CompiledProfile -> Suite -> Either (NonEmpty BaselineFault) PreparedSuite+checkBaseline renderViolation compiled suite =+  case acceptanceFaults <> caseFaults of+    firstFault : moreFaults -> Left (firstFault :| moreFaults)+    [] ->+      Right+        PreparedSuite+          { suite,+            render = renderViolation,+            baseline = compiled,+            baselineViolations = caseViolations,+            keyOf = behaviourKey,+            baselineKey = behaviourKey compiled+          }+  where+    acceptanceFaults = concatMap acceptanceFault (suite ^. #acceptance)+    acceptanceFault bundle'+      | not (null coreErrors && null staleness) = [AcceptanceCoreInvalid (bundle' ^. #path) coreErrors staleness]+      | not (null violations) = [AcceptanceProfileDeviations (bundle' ^. #path) (deviationLines renderViolation compiled bundle' violations)]+      | otherwise = []+      where+        coreErrors =+          validateBundle StrictAuthoring (bundle' ^. #declaration) (bundle' ^. #inventory) (bundle' ^. #concepts)+            <> validateBundleLogs (bundle' ^. #logs)+        staleness = logStaleness (bundle' ^. #concepts) (bundle' ^. #logs)+        violations = profileViolations StrictAuthoring compiled bundle'+    caseViolations = [profileViolations PermissiveConformance compiled (rejection ^. #bundle) | rejection <- suite ^. #cases]+    caseFaults =+      [ CaseExpectationUnmet (rejection ^. #name) (rejection ^. #expectation) lines'+      | (rejection, violations) <- zip (suite ^. #cases) caseViolations,+        let lines' = deviationLines renderViolation compiled (rejection ^. #bundle) violations,+        not (meetsExpectation (rejection ^. #expectation) lines')+      ]++-- | The relaxations a sweep evaluates, in order. Outside 'LegacyKinds', an+-- @allowedValues@ relaxation that makes the descriptor invalid (a @when@+-- condition needs the vocabulary) is followed by one @admitValue@ relaxation+-- per distinct value that some case's baseline 'ValueNotInVocabulary' violation+-- reports at that rule, so that the vocabulary can still be shown load-bearing.+planRelaxations :: KindSet -> PreparedSuite -> [Relaxation]+planRelaxations kinds prepared =+  concatMap expand (enumerateRelaxations kinds spec)+  where+    spec = compiledProfileSpec (prepared ^. #baseline)+    expand relaxation@Relaxation {target, kind}+      | kinds /= LegacyKinds,+        kind == ClearVocabulary,+        Left _ <- compileProfile (applyRelaxation relaxation spec) =+          relaxation : [Relaxation target (AdmitValue value) | value <- admissibleValues target]+      | otherwise = [relaxation]+    admissibleValues target =+      List.nub+        [ value+        | (rejection, violations) <- zip (prepared ^. #suite . #cases) (prepared ^. #baselineViolations),+          ValueNotInVocabulary conceptId path _ (String value) <- violations,+          inScope target (conceptTypes rejection) conceptId,+          pathNames path == targetPath target+        ]++-- | What one relaxation did to the suite.+data Observation = Observation+  { -- | non-empty when the relaxed descriptor no longer compiles+    definitionErrors :: ![ProfileDefinitionError],+    -- | acceptance bundles that deviate from the relaxed profile, with their+    -- rendered lines+    acceptanceDeviations :: ![(FilePath, [Text])],+    -- | cases that no longer meet their expectation, in legacy order: cases+    -- expecting the relaxed field first, then the rest in @expected.json@ order+    witnesses :: ![Text],+    -- | cases in which a baseline violation of the relaxation's own kind at the+    -- relaxed rule disappears, whether or not the case still fails otherwise+    facetWitnesses :: ![Text],+    -- | the relaxed profile compiles to the baseline's 'BehaviourKey'+    behaviourUnchanged :: !Bool+  }+  deriving stock (Generic, Eq, Show)++-- | The witness the Python sweep would name: the first in legacy order.+primaryWitness :: Observation -> Maybe Text+primaryWitness observation = listToMaybe (observation ^. #witnesses)++-- | The Python sweep's verdict, with its precedence: a descriptor that does not+-- compile or an acceptance deviation is @acceptance-fails@, then the primary+-- witness, then @UNPROTECTED@.+legacyOutcome :: Observation -> Text+legacyOutcome observation+  | not (null (observation ^. #definitionErrors)) = "acceptance-fails"+  | not (null (observation ^. #acceptanceDeviations)) = "acceptance-fails"+  | Just witness <- primaryWitness observation = "fixture " <> witness+  | otherwise = "UNPROTECTED"++-- | Apply one relaxation, recompile, and evaluate every acceptance bundle and+-- every case. All witnesses are collected, not only the first.+observeRelaxation :: PreparedSuite -> Relaxation -> Observation+observeRelaxation prepared relaxation =+  case compileProfile (applyRelaxation relaxation (compiledProfileSpec (prepared ^. #baseline))) of+    Left errors -> Observation (toList errors) [] [] [] False+    Right compiled ->+      let evaluated =+            [ (rejection, before, after)+            | (rejection, before) <- zip (prepared ^. #suite . #cases) (prepared ^. #baselineViolations),+              let after = profileViolations PermissiveConformance compiled (rejection ^. #bundle)+            ]+          noticed =+            [ (rejection ^. #name, rejection ^. #expectation . #field)+            | (rejection, _, after) <- evaluated,+              not (meetsExpectation (rejection ^. #expectation) (deviationLines renderViolation compiled (rejection ^. #bundle) after))+            ]+       in Observation+            { definitionErrors = [],+              acceptanceDeviations =+                [ (bundle' ^. #path, deviationLines renderViolation compiled bundle' violations)+                | bundle' <- prepared ^. #suite . #acceptance,+                  let violations = profileViolations StrictAuthoring compiled bundle',+                  not (null violations)+                ],+              witnesses = map fst (legacyOrder (relaxationField relaxation) noticed),+              facetWitnesses =+                [ rejection ^. #name+                | (rejection, before, after) <- evaluated,+                  any (\violation -> isFacet (conceptTypes rejection) violation && violation `notElem` after) before+                ],+              behaviourUnchanged = (prepared ^. #keyOf) compiled == prepared ^. #baselineKey+            }+  where+    renderViolation = prepared ^. #render+    facets = kindFacets (relaxation ^. #kind)+    isFacet typesById violation =+      or+        [ facet `elem` facets && inScope (relaxation ^. #target) typesById conceptId && facetPathMatches facet names (targetPath (relaxation ^. #target))+        | (conceptId, facet, names) <- violationFacets violation+        ]++-- | Order (case, expected field) pairs as the Python sweep does: cases+-- expecting the given field first, the rest after, each group in+-- @expected.json@ order (a stable sort).+legacyOrder :: Text -> [(Text, Text)] -> [(Text, Text)]+legacyOrder fieldName = List.sortOn ((/= fieldName) . snd)++conceptTypes :: RejectionCase -> Map ConceptId Text+conceptTypes rejection = Map.fromList [(conceptIdOf concept, conceptType concept) | concept <- rejection ^. #bundle . #concepts]++inScope :: RelaxationTarget -> Map ConceptId Text -> ConceptId -> Bool+inScope target typesById conceptId = case target of+  RuleTarget RuleLocation {scope = ProfileScope} -> True+  RuleTarget RuleLocation {scope = TypeScope typeName} -> Map.lookup conceptId typesById == Just typeName+  TypeTarget typeName -> Map.lookup conceptId typesById == Just typeName++-- | The field names a relaxation's rule governs, outermost first; empty for a+-- type attribute.+targetPath :: RelaxationTarget -> [Text]+targetPath = \case+  RuleTarget RuleLocation {field = fieldName, nested} -> fieldName : maybe [] (\(_, _, innerField) -> [innerField]) nested+  TypeTarget _ -> []++pathNames :: FieldPath -> [Text]+pathNames (FieldPath segments) = [name' | FieldName name' <- toList segments]++-- | Which kind of check a violation reports, so a relaxation can be credited+-- with the disappearance of exactly the checks it weakens.+data Facet+  = MissingFacet+  | VocabularyFacet+  | FormatFacet+  | UniquenessFacet+  | LocalFacet+  | SelfFacet+  | PatternFacet+  | CardinalityFacet+  | ReferenceFacet+  | PathFacet+  | PathPatternFacet+  | ResourceFacet+  | SchemaSectionFacet+  | SchemaColumnsFacet+  | DocumentIdFacet+  deriving stock (Eq, Show)++violationFacets :: ProfileViolation -> [(ConceptId, Facet, [Text])]+violationFacets = \case+  MissingProfileField conceptId key _ -> [(conceptId, MissingFacet, [key])]+  MissingNestedProfileField conceptId path _ -> [(conceptId, MissingFacet, pathNames path)]+  ValueNotInVocabulary conceptId path _ _ -> [(conceptId, VocabularyFacet, pathNames path)]+  ValueFormatMismatch conceptId path _ _ -> [(conceptId, FormatFacet, pathNames path)]+  DuplicateNestedFieldValue conceptId path _ _ -> [(conceptId, UniquenessFacet, pathNames path)]+  CardinalityMismatch conceptId path _ _ -> [(conceptId, CardinalityFacet, pathNames path)]+  LocalDocumentReferenceNotAllowed conceptId path _ -> reference conceptId path [LocalFacet]+  SelfDocumentReference conceptId path _ -> reference conceptId path [SelfFacet, PathFacet]+  ExternalReferencePatternMismatch conceptId path _ _ -> reference conceptId path [PatternFacet]+  DanglingHandleReference conceptId path _ -> reference conceptId path []+  ReferenceHandlePrefixMismatch conceptId path _ _ -> reference conceptId path []+  MalformedDocumentReference conceptId path _ -> reference conceptId path [PathFacet]+  ExternalReferenceSchemeNotAllowed conceptId path _ _ -> reference conceptId path [PathFacet]+  MalformedPathReference conceptId path _ -> [(conceptId, PathFacet, pathNames path)]+  PathEscapesBundle conceptId path _ -> [(conceptId, PathFacet, pathNames path)]+  DanglingPathReference conceptId path _ -> [(conceptId, PathFacet, pathNames path)]+  PathPatternMismatch conceptId _ _ -> [(conceptId, PathPatternFacet, [])]+  MissingResource conceptId _ _ -> [(conceptId, ResourceFacet, [])]+  ResourceSchemeMismatch conceptId _ _ -> [(conceptId, ResourceFacet, [])]+  MissingSchemaSection conceptId _ -> [(conceptId, SchemaSectionFacet, [])]+  SchemaColumnsMismatch conceptId _ _ _ -> [(conceptId, SchemaColumnsFacet, [])]+  MissingDocumentId conceptId _ _ -> [(conceptId, DocumentIdFacet, [])]+  MalformedDocumentId conceptId _ _ -> [(conceptId, DocumentIdFacet, [])]+  _ -> []+  where+    reference conceptId path extra = [(conceptId, facet, pathNames path) | facet <- ReferenceFacet : extra]++kindFacets :: RelaxationKind -> [Facet]+kindFacets = \case+  Delete -> [MissingFacet]+  Presence -> [MissingFacet]+  ClearVocabulary -> [VocabularyFacet]+  AdmitValue _ -> [VocabularyFacet]+  DropFormat -> [FormatFacet]+  DropUniqueBy -> [UniquenessFacet]+  AllowSelf -> [SelfFacet]+  AllowLocal -> [LocalFacet]+  DropExternalUriPattern -> [PatternFacet]+  DropCardinality -> [CardinalityFacet]+  DropCondition -> [MissingFacet]+  DropPath -> [PathFacet]+  DropReference -> [ReferenceFacet]+  DropNested _ -> []+  DropTypeAttribute attribute -> case attribute of+    PathPattern -> [PathPatternFacet]+    ResourceScheme -> [ResourceFacet]+    RequireSchemaSection -> [SchemaSectionFacet]+    SchemaColumns -> [SchemaColumnsFacet]+    IdPrefix -> [DocumentIdFacet]+  DropListShape -> [CardinalityFacet]+  DropHandleIdentity -> [DocumentIdFacet, FormatFacet]+  DropUniqueKey -> [MissingFacet, UniquenessFacet]++-- | A facet violation belongs to a rule when its field names are the rule's;+-- a uniqueness violation names the duplicated member below the list rule, and a+-- type attribute's violations name no field at all.+facetPathMatches :: Facet -> [Text] -> [Text] -> Bool+facetPathMatches facet names rulePath = case facet of+  UniquenessFacet -> rulePath `List.isPrefixOf` names+  _ | null rulePath -> True+  _ -> names == rulePath++profileViolations :: ValidationProfile -> CompiledProfile -> SuiteBundle -> [ProfileViolation]+profileViolations mode compiled bundle' =+  validateProfileVersion (bundle' ^. #declaration) compiled+    <> validateProfileWith (bundle' ^. #inventory) mode compiled (bundle' ^. #concepts)++-- | The deviation lines @okf validate@ prints, as the catalog's harness reads+-- them: each violation is printed behind @profile: @, and a line counts when it+-- starts with that prefix and is not the advisory summary.+deviationLines :: Render -> CompiledProfile -> SuiteBundle -> [ProfileViolation] -> [Text]+deviationLines renderViolation compiled bundle' =+  filter isDeviationLine . concatMap (Text.lines . ("profile: " <>) . renderViolation compiled (bundle' ^. #concepts))+  where+    isDeviationLine line =+      "profile: " `Text.isPrefixOf` line && not ("advisory deviation(s)" `Text.isInfixOf` line)++meetsExpectation :: CaseExpectation -> [Text] -> Bool+meetsExpectation CaseExpectation {field = fieldName, count} lines' =+  length lines' == count && any (fieldName `Text.isInfixOf`) lines'++-- | The relaxation that weakens a whole composite policy unit of which this+-- relaxation weakens one member, per the okf-profiles catalog's ADR-9: a+-- member's effect can be masked by the unit's other members, so a member no+-- case notices is covered when some case notices the unit.+--+-- The units are a handle @reference@ (members @allowLocal@, @allowSelf@ and+-- @externalUriPattern@), a list rule's shape (its 'List' cardinality and its+-- @elementFields@), and a type's handle identity (its @idPrefix@ and the+-- @DocumentHandle@ format of its @idField@ rule). A fourth is okf's own: a+-- list rule's @uniqueBy@ and its key member's presence, because+-- 'Okf.Profile.compileProfile' rejects a @uniqueBy@ key that is not+-- unconditionally required, so deleting or demoting the key alone never+-- compiles.+compositeUnit :: ProfileSpec -> Relaxation -> Maybe Relaxation+compositeUnit spec Relaxation {target, kind} = case (target, kind) of+  (RuleTarget _, AllowLocal) -> Just (Relaxation target DropReference)+  (RuleTarget _, AllowSelf) -> Just (Relaxation target DropReference)+  (RuleTarget _, DropExternalUriPattern) -> Just (Relaxation target DropReference)+  (RuleTarget location@RuleLocation {nested = Nothing}, DropCardinality)+    | Just rule <- topLevelRule spec location,+      rule ^. #cardinality == List,+      isJust (rule ^. #elementFields) ->+        Just (Relaxation target DropListShape)+  (RuleTarget RuleLocation {nested = Nothing}, DropNested ElementFields) -> Just (Relaxation target DropListShape)+  (RuleTarget location@RuleLocation {scope = TypeScope typeName, field = fieldName, nested = Nothing}, DropFormat)+    | spec ^. #idField == Just fieldName,+      Just rule <- topLevelRule spec location,+      Just (DocumentHandle _) <- rule ^. #format,+      typeHasIdPrefix typeName ->+        Just (Relaxation (TypeTarget typeName) DropHandleIdentity)+  (TypeTarget typeName, DropTypeAttribute IdPrefix) -> Just (Relaxation (TypeTarget typeName) DropHandleIdentity)+  (RuleTarget location@RuleLocation {nested = Just (ElementFields, RequiredList, key)}, memberKind)+    | memberKind == Delete || memberKind == Presence,+      Just rule <- topLevelRule spec location,+      rule ^. #uniqueBy == Just key ->+        Just (Relaxation target DropUniqueKey)+  _ -> Nothing+  where+    typeHasIdPrefix typeName = any (\rule -> rule ^. #type_ == typeName && isJust (rule ^. #idPrefix)) (spec ^. #types)++topLevelRule :: ProfileSpec -> RuleLocation -> Maybe FieldRule+topLevelRule spec RuleLocation {scope, list = presenceList, field = fieldName} =+  listToMaybe (filter (named fieldName) (concatMap (^. presenceListOf presenceList) scopes))+  where+    scopes = case scope of+      ProfileScope -> [spec ^. #frontmatter]+      TypeScope typeName -> [rule ^. #frontmatter | rule <- spec ^. #types, rule ^. #type_ == typeName]++-- | What a compiled profile makes the validator do, with what it provably never+-- consults erased, so that two compiled profiles with equal keys produce the+-- same violations on every bundle. Built from the public inspection accessors.+--+-- The erasures, each with the function that proves it:+--+-- * Descriptions and guidance. The validator never reads them; the CLI's+--   renderer reads a field's description only for a missing-field violation,+--   which only a rule with a presence clause produces, so a description is kept+--   exactly when the effective rule has one.+-- * A rule that constrains nothing (no presence clause, no vocabulary, 'Any'+--   cardinality, no format, nested shape, reference, path or uniqueness) in an+--   open record: 'validateProfileWith' checks a present key only against its+--   rule, and reports an undeclared key only when the record is closed.+-- * @allowSelf@ in a handle reference whose effective @allowLocal@ is 'False':+--   @validateReferenceText@ rejects every local handle before it reads+--   @allowSelf@.+-- * @externalUriPattern@ when @externalUriSchemes@ is empty:+--   @validateReferenceText@ reads the pattern only for a URI whose scheme is+--   allowed.+data BehaviourKey = BehaviourKey+  { allowUnknownTypes :: !Bool,+    allowUnknownFields :: !Bool,+    idField :: !(Maybe Text),+    requiredBundleVersion :: !(Maybe OkfVersion),+    typeAttributes :: ![(Text, Maybe Text, Maybe Text, Bool, [Text], Maybe Text)],+    baseRules :: !(Map Text RuleKey),+    baseConstraints :: !EffectiveConceptConstraints,+    typeRules :: ![(Text, Map Text RuleKey, EffectiveConceptConstraints)]+  }+  deriving stock (Generic, Eq, Show)++data RuleKey = RuleKey+  { presence :: ![(FieldRequirement, Maybe FieldCondition)],+    description :: !(Maybe Text),+    allowedValues :: ![Text],+    cardinality :: !Cardinality,+    format :: !(Maybe FieldFormat),+    elementFields :: !(Maybe (Map Text RuleKey)),+    objectFields :: !(Maybe (Map Text RuleKey)),+    elementOpen :: !(Maybe Bool),+    objectOpen :: !(Maybe Bool),+    reference :: !(Maybe HandleReferenceRule),+    path :: !(Maybe PathReferenceRule),+    uniqueBy :: !(Maybe Text),+    elementConstraints :: !EffectiveConceptConstraints,+    objectConstraints :: !EffectiveConceptConstraints+  }+  deriving stock (Generic, Eq, Show)++behaviourKey :: CompiledProfile -> BehaviourKey+behaviourKey compiled =+  BehaviourKey+    { allowUnknownTypes = spec ^. #allowUnknownTypes,+      allowUnknownFields = open,+      idField = spec ^. #idField,+      requiredBundleVersion = compiledProfileRequiredBundleVersion compiled,+      typeAttributes =+        [ (rule ^. #type_, rule ^. #pathPattern, rule ^. #resourceScheme, rule ^. #requireSchemaSection, rule ^. #schemaColumns, rule ^. #idPrefix)+        | rule <- spec ^. #types+        ],+      baseRules = rulesKey open (compiledProfileBaseRules compiled),+      baseConstraints = compiledProfileBaseConstraints compiled,+      typeRules =+        [ (typeName, rulesKey open (compiledProfileRulesForType compiled typeName), compiledProfileConstraintsForType compiled typeName)+        | typeName <- compiledProfileTypeNames compiled+        ]+    }+  where+    spec = compiledProfileSpec compiled+    open = spec ^. #allowUnknownFields++rulesKey :: Bool -> Map Text EffectiveFieldRule -> Map Text RuleKey+rulesKey open = Map.mapMaybe $ \rule ->+  let key = ruleKey rule+   in if open && constrainsNothing key then Nothing else Just key++ruleKey :: EffectiveFieldRule -> RuleKey+ruleKey rule =+  RuleKey+    { presence,+      description = if null presence then Nothing else fieldRuleDescription rule,+      allowedValues = fieldRuleAllowedValues rule,+      cardinality = fieldRuleCardinality rule,+      format = fieldRuleFormat rule,+      elementFields = rulesKey (elementOpen == Just True) <$> fieldRuleElementFields rule,+      objectFields = rulesKey (objectOpen == Just True) <$> fieldRuleObjectFields rule,+      elementOpen,+      objectOpen,+      reference = eraseUnread <$> fieldRuleReference rule,+      path = fieldRulePath rule,+      uniqueBy = fieldRuleUniqueBy rule,+      elementConstraints = fieldRuleElementConstraints rule,+      objectConstraints = fieldRuleObjectConstraints rule+    }+  where+    presence = [(presenceClauseRequirement clause, presenceClauseCondition clause) | clause <- fieldRulePresenceClauses rule]+    elementOpen = fieldRuleElementAllowsUnknownFields rule+    objectOpen = fieldRuleObjectAllowsUnknownFields rule+    eraseUnread policy =+      policy+        & (if policy ^. #allowLocal then id else #allowSelf .~ False)+        & (if null (policy ^. #externalUriSchemes) then #externalUriPattern .~ Nothing else id)++constrainsNothing :: RuleKey -> Bool+constrainsNothing key =+  null (key ^. #presence)+    && null (key ^. #allowedValues)+    && key ^. #cardinality == Any+    && isNothing (key ^. #format)+    && isNothing (key ^. #elementFields)+    && isNothing (key ^. #objectFields)+    && isNothing (key ^. #reference)+    && isNothing (key ^. #path)+    && isNothing (key ^. #uniqueBy)++-- | Why okf cannot decide a relaxation itself, as documented beside the cases.+data ExceptionClass+  = -- | the rule is spliced from a shared family tested in its home profile+    SharedFamily !Text+  | -- | another rule or type attribute governs the same value+    OverlappingRule !Text+  | -- | a known gap, deferred to the named request (a @mori://@ URI)+    Deferred !Text+  deriving stock (Generic, Eq, Show)++data SweepException = SweepException+  { relaxation :: !Text,+    exceptionClass :: !ExceptionClass,+    rationale :: !Text+  }+  deriving stock (Generic, Eq, Show)++loadExceptions :: FilePath -> IO (Either Text [SweepException])+loadExceptions manifestPath = do+  read' <- try (LazyBytes.readFile manifestPath)+  pure $ case read' of+    Left (readError :: IOException) -> Left (Text.pack (show readError))+    Right bytes -> parseExceptions bytes++-- | Read an exception manifest:+-- @{"version": 1, "exceptions": [{"relaxation": ID, "class": C, …, "rationale": R}]}@.+-- The class is closed: @shared-family@ needs @home@, @overlapping-rule@ needs+-- @overlapsWith@, and @deferred@ needs @request@, a @mori://@ URI.+parseExceptions :: LazyBytes.ByteString -> Either Text [SweepException]+parseExceptions bytes = do+  value <- first Text.pack (Aeson.eitherDecode bytes)+  manifest <- case value of+    Aeson.Object manifest -> Right manifest+    _ -> Left "expected a JSON object with version and exceptions"+  case KeyMap.lookup "version" manifest of+    Just (Number 1) -> Right ()+    _ -> Left "unsupported manifest version; expected \"version\": 1"+  entries <- case KeyMap.lookup "exceptions" manifest of+    Just (Array entries) -> Right (toList entries)+    _ -> Left "expected an \"exceptions\" array"+  for (zip [0 :: Int ..] entries) $ \(entryIndex, entry) ->+    first (\reason -> "exceptions[" <> Text.pack (show entryIndex) <> "]: " <> reason) $ case entry of+      Aeson.Object fields -> do+        relaxation <- text fields "relaxation"+        rationale <- text fields "rationale"+        exceptionClass <-+          text fields "class" >>= \case+            "shared-family" -> SharedFamily <$> text fields "home"+            "overlapping-rule" -> OverlappingRule <$> text fields "overlapsWith"+            "deferred" -> do+              request <- text fields "request"+              if "mori://" `Text.isPrefixOf` request then Right (Deferred request) else Left "request must be a mori:// URI"+            other -> Left ("unknown class " <> other <> "; expected shared-family, overlapping-rule or deferred")+        Right (SweepException relaxation exceptionClass rationale)+      _ -> Left "expected an object"+  where+    text fields key = case KeyMap.lookup key fields of+      Just (String value) | not (Text.null (Text.strip value)) -> Right value+      _ -> Left ("missing or empty \"" <> Key.toText key <> "\"")++-- | How one relaxation is classified. The first matching rule decides:+--+-- 1. 'Protected': some case noticed it, and the descriptor still compiles and+--    every acceptance bundle still passes.+-- 2. 'Subsumed': a @delete@ that fails a descriptor or acceptance check, while+--    every other relaxation of the same rule is non-failing.+-- 3. 'Covered' by an @admitValue@: an @allowedValues@ relaxation the+--    descriptor cannot express, while admitting one reported value is noticed.+-- 4. 'DescriptorInvalidOutcome' or 'AcceptanceObservableOutcome'. A+--    descriptor the relaxation cannot express is first 'Covered' when its+--    composite unit is protected (rule 6), or an 'ExceptionOutcome' when the+--    manifest documents it (rule 7).+-- 5. 'Inert': the relaxed profile has the baseline's 'BehaviourKey'.+-- 6. 'Covered' by a composite unit ('compositeUnit') that is protected.+-- 7. 'ExceptionOutcome': no witness, and the manifest documents it.+-- 8. 'Unprotected'.+--+-- 'Contradiction' is okf's own bug: a relaxation with an unchanged behaviour+-- key that some case nevertheless noticed.+data Outcome+  = Protected+  | Subsumed ![Text]+  | -- | the covering relaxation and its witness+    Covered !Text !Text+  | DescriptorInvalidOutcome+  | AcceptanceObservableOutcome+  | Inert !Text+  | ExceptionOutcome !SweepException+  | Unprotected+  | Contradiction+  deriving stock (Generic, Eq, Show)++outcomeName :: Outcome -> Text+outcomeName = \case+  Protected -> "protected"+  Subsumed _ -> "subsumed"+  Covered _ _ -> "covered"+  DescriptorInvalidOutcome -> "descriptor-invalid"+  AcceptanceObservableOutcome -> "acceptance-observable"+  Inert _ -> "inert"+  ExceptionOutcome _ -> "exception"+  Unprotected -> "unprotected"+  Contradiction -> "contradiction"++outcomeIsFailing :: Outcome -> Bool+outcomeIsFailing = \case+  DescriptorInvalidOutcome -> True+  AcceptanceObservableOutcome -> True+  Unprotected -> True+  Contradiction -> True+  _ -> False++data SweepResult = SweepResult+  { relaxation :: !Relaxation,+    observation :: !Observation,+    outcome :: !Outcome+  }+  deriving stock (Generic, Eq, Show)++-- | Evaluate and classify the given relaxations, normally 'planRelaxations' or+-- a filtered part of it, one rule location (or type) at a time. The list is+-- lazy per group: consuming the first group does not force later groups, and a+-- group's results, which may depend on each other, are yielded in the order+-- given. Composite units evaluated to classify a member are reported only+-- through 'Covered'.+sweepProfile :: [SweepException] -> PreparedSuite -> [Relaxation] -> [SweepResult]+sweepProfile exceptions prepared =+  concatMap evaluateGroup . List.groupBy (\left right -> left ^. #target == right ^. #target)+  where+    spec = compiledProfileSpec (prepared ^. #baseline)+    manifest = Map.fromList [(entry ^. #relaxation, entry) | entry <- exceptions]+    -- Lazy maps on purpose: a delete's outcome reads its siblings' outcomes+    -- from the same map, and a unit is observed only if a member asks for it.+    evaluateGroup group =+      let observed = LazyMap.fromList [(relaxation, observeRelaxation prepared relaxation) | relaxation <- group]+          units = LazyMap.fromList [(unit, observeRelaxation prepared unit) | Just unit <- map (compositeUnit spec) group]+          outcomes = LazyMap.mapWithKey classify observed+          classify relaxation observation+            | observation ^. #behaviourUnchanged, not (null (observation ^. #witnesses)) = Contradiction+            | protects observation = Protected+            | relaxation ^. #kind == Delete,+              failsCheck observation,+              all (nonFailing . (outcomes LazyMap.!)) siblings =+                Subsumed (map relaxationId siblings)+            | relaxation ^. #kind == ClearVocabulary,+              not (null (observation ^. #definitionErrors)),+              (admitted, witness) : _ <-+                [ (sibling, witness)+                | sibling@Relaxation {kind = AdmitValue _} <- siblings,+                  Protected <- [outcomes LazyMap.! sibling],+                  Just witness <- [primaryWitness (observed LazyMap.! sibling)]+                ] =+                Covered (relaxationId admitted) witness+            | not (null (observation ^. #definitionErrors)),+              Just covered <- unitCover relaxation =+                covered+            | not (null (observation ^. #definitionErrors)),+              Just entry <- Map.lookup (relaxationId relaxation) manifest =+                ExceptionOutcome entry+            | not (null (observation ^. #definitionErrors)) = DescriptorInvalidOutcome+            | not (null (observation ^. #acceptanceDeviations)) = AcceptanceObservableOutcome+            | observation ^. #behaviourUnchanged = Inert (inertReason relaxation)+            | Just covered <- unitCover relaxation = covered+            | Just entry <- Map.lookup (relaxationId relaxation) manifest = ExceptionOutcome entry+            | otherwise = Unprotected+            where+              siblings = filter (/= relaxation) group+          unitCover relaxation = do+            unit <- compositeUnit spec relaxation+            unitObservation <- LazyMap.lookup unit units+            witness <- primaryWitness unitObservation+            if protects unitObservation then Just (Covered (relaxationId unit) witness) else Nothing+       in [SweepResult relaxation (observed LazyMap.! relaxation) (outcomes LazyMap.! relaxation) | relaxation <- group]+    protects observation =+      not (null (observation ^. #witnesses))+        && null (observation ^. #definitionErrors)+        && null (observation ^. #acceptanceDeviations)+    failsCheck observation =+      not (null (observation ^. #definitionErrors)) || not (null (observation ^. #acceptanceDeviations))+    nonFailing = \case+      Protected -> True+      Inert _ -> True+      Covered _ _ -> True+      ExceptionOutcome _ -> True+      _ -> False++inertReason :: Relaxation -> Text+inertReason Relaxation {kind} = case kind of+  AllowSelf -> "allowSelf is never read while allowLocal is False"+  DropExternalUriPattern -> "externalUriPattern is never read while externalUriSchemes is empty"+  _ -> "the relaxed profile compiles to the same behaviour key as the baseline"++-- | Manifest entries that no longer describe a gap: the entry's relaxation was+-- evaluated and classified as something other than an exception, or it names a+-- relaxation this run's kinds would enumerate and none was. With @onlySome@+-- (an @--only@ run) an entry for a relaxation that was not swept is not stale.+staleExceptions :: KindSet -> Bool -> [SweepException] -> [(Text, Outcome)] -> [SweepException]+staleExceptions kinds onlySome exceptions results =+  filter stale exceptions+  where+    outcomes = Map.fromList results+    stale entry = case Map.lookup (entry ^. #relaxation) outcomes of+      Just (ExceptionOutcome _) -> False+      Just _ -> True+      Nothing -> not onlySome && enumeratedBy (snd (Text.breakOnEnd "#" (entry ^. #relaxation)))+    enumeratedBy kindName+      | kindName `elem` legacyNames = True+      | kindName == "presence" || "admitValue:" `Text.isPrefixOf` kindName = kinds /= LegacyKinds+      | otherwise = kinds == AllKinds+    legacyNames = mapMaybe legacyKindName [Delete, ClearVocabulary, DropFormat, DropUniqueBy, AllowSelf, AllowLocal, DropExternalUriPattern]

@@ -10,7 +10,7 @@ import Data.List qualified as List import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map-import Data.Maybe (catMaybes, mapMaybe, maybeToList)+import Data.Maybe (catMaybes, listToMaybe, mapMaybe, maybeToList) import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.IO qualified as Text.IO@@ -41,6 +41,7 @@ import Okf.Profile.Discovery qualified as ProfileDiscovery import Okf.Profile.Documentation import Okf.Profile.Registry+import Okf.Profile.Sweep qualified as Sweep import Okf.Query import Okf.Trust import Okf.Validation@@ -164,6 +165,17 @@         testIO "loadProfileFile decodes the postgresql fixture" testLoadProfileFixture,         testIO "loadProfileFile decodes record-completed document ID rules" testLoadDocumentIdProfileFixture,         testIO "loadProfileFile exposes nested reference and uniqueness declarations" testLoadNestedReferenceProfileFixture,+        testIO "sweep enumerates relaxations in declaration order" testSweepEnumeration,+        testIO "sweep applies each relaxation kind to the authored descriptor" testSweepApplyRelaxation,+        test "sweep reads expected.json in file order" testSweepExpectationOrder,+        testIO "sweep finds witnesses and unprotected relaxations on a two-case suite" testSweepWitnesses,+        testIO "sweep baseline reports a case that does not meet its expectation" testSweepBaselineFault,+        testIO "sweep classifies an open profile's relaxations by evidence and proof" testSweepClassification,+        testIO "sweep classifies closed-profile deletions as subsumed or acceptance-observable" testSweepClosedProfile,+        testIO "sweep reports an inert relaxation some case notices as a contradiction" testSweepContradiction,+        testIO "sweep applies manifest exceptions and reports stale ones" testSweepExceptions,+        test "sweep rejects malformed exception manifests" testSweepMalformedExceptions,+        testIO "behaviourKey erases only what validation never consults" testSweepBehaviourKeyErasures,         testIO "loadProfileFile accepts the pre-type-frontmatter described schema" testLoadDescribedProfileFixture,         testIO "loadProfileFile accepts the frozen EP-1 type-aware schema" testLoadTypeAwareCompatibilityFixture,         testIO "loadProfileFile accepts the frozen EP-2 vocabulary schema" testLoadVocabularyCompatibilityFixture,@@ -8577,3 +8589,353 @@   assertEqual (violationsFor True "stray") (unknowns coexist)   assertEqual 1 (length [() | ConstraintPresenceMissing {} <- coexist])   assertEqual 1 (length [() | TimestampOrderViolation {} <- coexist])++-- Load-bearing sweeps ---------------------------------------------------------++-- | A renderer that needs nothing from the CLI: 'show' names the field, which is+-- all the legacy predicate looks for.+showRender :: Sweep.Render+showRender _ _ violation = Text.pack (show violation)++loadSweepFixture :: IO (ProfileSpec, CompiledProfile, Sweep.Suite)+loadSweepFixture = do+  profilePath <- fixtureFilePath "sweep/profile.dhall"+  acceptPath <- fixturePath "sweep/accept"+  casesPath <- fixturePath "sweep/cases"+  spec <- either (fail . Text.unpack) pure =<< loadProfileFile profilePath+  compiled <- either (fail . show) pure (compileProfile spec)+  suite <- either (fail . show) pure =<< Sweep.loadSuite [acceptPath] casesPath+  pure (spec, compiled, suite)++testSweepEnumeration :: IO (Either Text ())+testSweepEnumeration = do+  (spec, _, _) <- loadSweepFixture+  nestedPath <- fixtureFilePath "profiles/nested-references-and-uniqueness.dhall"+  nestedSpec <- either (fail . Text.unpack) pure =<< loadProfileFile nestedPath+  pure $ do+    assertEqual+      [ "profile/required/type#delete",+        "profile/required/title#delete",+        "type:Note/required/status#delete",+        "type:Note/required/status#allowedValues",+        "type:Note/optional/summary#delete"+      ]+      (map Sweep.relaxationId (Sweep.enumerateRelaxations Sweep.LegacyKinds spec))+    assertEqual+      [ "profile/required/type#delete",+        "profile/required/type#presence",+        "profile/required/title#delete",+        "profile/required/title#presence",+        "type:Note/required/status#delete",+        "type:Note/required/status#presence",+        "type:Note/required/status#allowedValues",+        "type:Note/optional/summary#delete"+      ]+      (map Sweep.relaxationId (Sweep.enumerateRelaxations Sweep.DefaultKinds spec))+    assertEqual+      [ "profile/required/type#delete",+        "profile/required/requestId#delete",+        "profile/required/requestId#format",+        "profile/required/dependencies#delete",+        "profile/required/dependencies/elementFields/required/ref#delete",+        "profile/required/dependencies/elementFields/required/ref#allowSelf",+        "profile/required/dependencies/elementFields/required/ref#allowLocal",+        "profile/required/dependencies/elementFields/required/ref#externalUriPattern",+        "profile/required/acceptanceCriteria#delete",+        "profile/required/acceptanceCriteria#uniqueBy",+        "profile/required/acceptanceCriteria/elementFields/required/id#delete",+        "profile/required/acceptanceCriteria/elementFields/required/id#format",+        "profile/required/acceptanceCriteria/elementFields/required/text#delete"+      ]+      (map Sweep.relaxationId (Sweep.enumerateRelaxations Sweep.LegacyKinds nestedSpec))+    assertEqual+      (Just "id")+      (listToMaybe [Sweep.relaxationField r | r <- Sweep.enumerateRelaxations Sweep.LegacyKinds nestedSpec, Sweep.relaxationId r == "profile/required/acceptanceCriteria/elementFields/required/id#format"])++testSweepApplyRelaxation :: IO (Either Text ())+testSweepApplyRelaxation = do+  (spec, _, _) <- loadSweepFixture+  nestedPath <- fixtureFilePath "profiles/nested-references-and-uniqueness.dhall"+  nestedSpec <- either (fail . Text.unpack) pure =<< loadProfileFile nestedPath+  let status = Sweep.RuleTarget (Sweep.RuleLocation (Sweep.TypeScope "Note") Sweep.RequiredList "status" Nothing)+      note relaxed = case relaxed ^. #types of+        [rule] -> Right (rule ^. #frontmatter)+        other -> Left ("expected one type rule, got " <> Text.pack (show (length other)))+      relax target kind = Sweep.applyRelaxation (Sweep.Relaxation target kind)+      fieldsOf = map (^. #field)+      ref = Sweep.RuleTarget (Sweep.RuleLocation Sweep.ProfileScope Sweep.RequiredList "dependencies" (Just (Sweep.ElementFields, Sweep.RequiredList, "ref")))+      nestedRef relaxed = do+        dependencies <- lookupRawRule "dependencies" (relaxed ^. #frontmatter . #required)+        case dependencies ^. #elementFields of+          Just nestedRules | [member] <- nestedRules ^. #required -> Right member+          _ -> Left "expected one nested rule under dependencies"+  pure $ do+    deleted <- note (relax status Sweep.Delete spec)+    assertEqual [] (fieldsOf (deleted ^. #required))+    demoted <- note (relax status Sweep.Presence spec)+    assertEqual [] (fieldsOf (demoted ^. #required))+    assertEqual ["summary", "status"] (fieldsOf (demoted ^. #optional))+    cleared <- note (relax status Sweep.ClearVocabulary spec)+    assertEqual [[]] (map (^. #allowedValues) (cleared ^. #required))+    admitted <- note (relax status (Sweep.AdmitValue "wip") spec)+    assertEqual [["draft", "final", "wip"]] (map (^. #allowedValues) (admitted ^. #required))+    anyShape <- note (relax status Sweep.DropCardinality spec)+    assertEqual [Any] (map (^. #cardinality) (anyShape ^. #required))+    assertEqual spec (relax (Sweep.RuleTarget (Sweep.RuleLocation (Sweep.TypeScope "Missing") Sweep.RequiredList "status" Nothing)) Sweep.Delete spec)+    selfAllowed <- nestedRef (relax ref Sweep.AllowSelf nestedSpec)+    assertEqual (Just True) ((^. #allowSelf) <$> selfAllowed ^. #reference)+    localAllowed <- nestedRef (relax ref Sweep.AllowLocal nestedSpec)+    assertEqual (Just True) ((^. #allowLocal) <$> localAllowed ^. #reference)+    unpatterned <- nestedRef (relax ref Sweep.DropExternalUriPattern nestedSpec)+    assertEqual (Just Nothing) ((^. #externalUriPattern) <$> unpatterned ^. #reference)+    unreferenced <- nestedRef (relax ref Sweep.DropReference nestedSpec)+    assertEqual Nothing (unreferenced ^. #reference)+    let criteria = Sweep.RuleTarget (Sweep.RuleLocation Sweep.ProfileScope Sweep.RequiredList "acceptanceCriteria" Nothing)+    notUnique <- lookupRawRule "acceptanceCriteria" (relax criteria Sweep.DropUniqueBy nestedSpec ^. #frontmatter . #required)+    assertEqual Nothing (notUnique ^. #uniqueBy)+    flat <- lookupRawRule "acceptanceCriteria" (relax criteria (Sweep.DropNested Sweep.ElementFields) nestedSpec ^. #frontmatter . #required)+    assertBool "elementFields dropped" (isNothing (flat ^. #elementFields))++testSweepExpectationOrder :: Either Text ()+testSweepExpectationOrder = do+  parsed <-+    Sweep.parseExpectations+      "{\"zeta\": \"status\", \"alpha\": {\"field\": \"docId\", \"diagnostics\": 2}, \"mid\": \"title\"}"+  assertEqual+    [ ("zeta", Sweep.CaseExpectation "status" 1),+      ("alpha", Sweep.CaseExpectation "docId" 2),+      ("mid", Sweep.CaseExpectation "title" 1)+    ]+    parsed+  assertBool "a non-object is rejected" (either (const True) (const False) (Sweep.parseExpectations "[]"))+  assertBool "a malformed entry is rejected" (either (const True) (const False) (Sweep.parseExpectations "{\"a\": 3}"))++testSweepWitnesses :: IO (Either Text ())+testSweepWitnesses = do+  (_, compiled, suite) <- loadSweepFixture+  pure $ do+    assertEqual ["note-missing-title", "note-bad-status"] (map (^. #name) (suite ^. #cases))+    prepared <- first (Text.pack . show) (Sweep.checkBaseline showRender compiled suite)+    let results = Sweep.sweepProfile [] prepared (Sweep.planRelaxations Sweep.LegacyKinds prepared)+        outcomes = [(Sweep.relaxationId (r ^. #relaxation), Sweep.legacyOutcome (r ^. #observation)) | r <- results]+    assertEqual+      [ ("profile/required/type#delete", "UNPROTECTED"),+        ("profile/required/title#delete", "fixture note-missing-title"),+        ("type:Note/required/status#delete", "fixture note-bad-status"),+        ("type:Note/required/status#allowedValues", "fixture note-bad-status"),+        ("type:Note/optional/summary#delete", "UNPROTECTED")+      ]+      outcomes++testSweepBaselineFault :: IO (Either Text ())+testSweepBaselineFault = do+  (_, compiled, suite) <- loadSweepFixture+  let misdirected =+        suite+          & #cases+          . traverse+          . filtered ((== "note-bad-status") . (^. #name))+          . #expectation+          . #field+          .~ "title"+  pure $ case Sweep.checkBaseline showRender compiled misdirected of+    Left (Sweep.CaseExpectationUnmet "note-bad-status" (Sweep.CaseExpectation "title" 1) [_] :| []) -> Right ()+    Left faults -> Left ("unexpected faults: " <> Text.pack (show faults))+    Right _ -> Left "a case whose expected field is wrong must fail the baseline"++lookupRawRule :: Text -> [FieldRule] -> Either Text FieldRule+lookupRawRule key rules =+  case [rule | rule <- rules, rule ^. #field == key] of+    [rule] -> Right rule+    _ -> Left ("expected one raw rule for " <> key)++sweepLogFile :: LogFile+sweepLogFile = LogFile "log.md" (parseLog "# Bundle Update Log\n\n## 2026-10-28\n* **Add**: Created the sweep fixture.\n")++sweepDocument :: [(Text, Text)] -> Text+sweepDocument fields =+  "---\n" <> Text.unlines [key <> ": " <> value | (key, value) <- fields] <> "---\n\n# Sweep fixture\n\nA concept.\n"++-- | A bundle held in memory, with one fresh log so strict acceptance passes.+memoryBundle :: FilePath -> [(Text, [(Text, Text)])] -> Either Text Sweep.SuiteBundle+memoryBundle bundlePath documents = do+  concepts <- for documents $ \(rawId, fields) -> do+    conceptId <- parseTestConceptId rawId+    document <- firstShow (parseDocument (sweepDocument fields))+    pure (conceptFromDocument conceptId document)+  pure (Sweep.SuiteBundle bundlePath concepts (bundleInventoryOfConcepts concepts) VersionUndeclared [sweepLogFile])++memoryCase :: Text -> Text -> [(Text, Text)] -> Either Text Sweep.RejectionCase+memoryCase caseName expected fields =+  Sweep.RejectionCase caseName (Sweep.CaseExpectation expected 1) <$> memoryBundle (Text.unpack caseName) [("tasks/" <> caseName, fields)]++setSweepField :: Text -> Text -> [(Text, Text)] -> [(Text, Text)]+setSweepField key value fields = [(k, v) | (k, v) <- fields, k /= key] <> [(key, value)]++baseTask :: [(Text, Text)]+baseTask =+  [ ("type", "Task"),+    ("title", "A task"),+    ("description", "A task in the sweep fixture."),+    ("timestamp", "\"2026-10-01T00:00:00Z\""),+    ("docId", "TASK-1"),+    ("status", "open")+  ]++loadCompiledFixture :: FilePath -> IO (ProfileSpec, CompiledProfile)+loadCompiledFixture name = do+  path <- fixtureFilePath name+  spec <- either (fail . Text.unpack) pure =<< loadProfileFile path+  compiled <- either (fail . show) pure (compileProfile spec)+  pure (spec, compiled)++-- | The classification fixture's suite: one accepted task and three cases, each+-- breaking exactly one rule.+classificationSuite :: Either Text Sweep.Suite+classificationSuite = do+  accept <- memoryBundle "accept" [("tasks/first", baseTask <> [("parent", "https://example.com/tasks/1")])]+  cases <-+    sequence+      [ memoryCase "task-bad-status" "status" (setSweepField "status" "wip" baseTask),+        memoryCase "task-local-parent" "parent" (baseTask <> [("parent", "TASK-9")]),+        memoryCase "task-missing-closedby" "closedBy" (setSweepField "status" "done" baseTask)+      ]+  pure (Sweep.Suite [accept] cases)++sweepOutcomes :: [Sweep.SweepException] -> Sweep.KindSet -> Sweep.PreparedSuite -> [(Text, Sweep.SweepResult)]+sweepOutcomes exceptions kinds prepared =+  [(Sweep.relaxationId (result ^. #relaxation), result) | result <- Sweep.sweepProfile exceptions prepared (Sweep.planRelaxations kinds prepared)]++expectOutcome :: [(Text, Sweep.SweepResult)] -> Text -> Sweep.Outcome -> Either Text ()+expectOutcome results relaxation expected =+  case lookup relaxation results of+    Nothing -> Left ("no result for " <> relaxation <> " among " <> Text.pack (show (map fst results)))+    Just result+      | result ^. #outcome == expected -> Right ()+      | otherwise -> Left (relaxation <> ": expected " <> Text.pack (show expected) <> ", got " <> Text.pack (show (result ^. #outcome)) <> " from " <> Text.pack (show (result ^. #observation)))++testSweepClassification :: IO (Either Text ())+testSweepClassification = do+  (_, compiled) <- loadCompiledFixture "sweep/classification.dhall"+  pure $ do+    suite <- classificationSuite+    prepared <- first (Text.pack . show) (Sweep.checkBaseline showRender compiled suite)+    let results = sweepOutcomes [] Sweep.DefaultKinds prepared+        expect = expectOutcome results+    -- A vocabulary a condition depends on cannot be cleared, so admitting the+    -- value a case reports stands in for it.+    expect "type:Task/required/status#admitValue:wip" Sweep.Protected+    expect "type:Task/required/status#allowedValues" (Sweep.Covered "type:Task/required/status#admitValue:wip" "task-bad-status")+    expect "type:Task/required/status#delete" Sweep.DescriptorInvalidOutcome+    expect "type:Task/required/status#presence" Sweep.Unprotected+    expect "type:Task/required/closedBy#delete" Sweep.Protected+    expect "type:Task/required/closedBy#presence" Sweep.Protected+    -- allowLocal turns the local-handle rejection into a dangling-handle one on+    -- the same field, which the legacy predicate cannot tell apart.+    expect "type:Task/optional/parent#allowLocal" (Sweep.Covered "type:Task/optional/parent#reference" "task-local-parent")+    assertEqual (Just ["task-local-parent"]) ((^. #observation . #facetWitnesses) <$> lookup "type:Task/optional/parent#allowLocal" results)+    expect "type:Task/optional/parent#allowSelf" (Sweep.Inert "allowSelf is never read while allowLocal is False")+    expect "type:Task/optional/note#delete" (Sweep.Inert "the relaxed profile compiles to the same behaviour key as the baseline")+    expect "type:Task/optional/priority#allowedValues" Sweep.Unprotected+    assertBool "a composite unit is not reported as its own result" (isNothing (lookup "type:Task/optional/parent#reference" results))+    assertBool "no protected result lacks a witness" (and [not (null (r ^. #observation . #witnesses)) | (_, r) <- results, r ^. #outcome == Sweep.Protected])++testSweepClosedProfile :: IO (Either Text ())+testSweepClosedProfile = do+  (_, compiled) <- loadCompiledFixture "sweep/closed.dhall"+  pure $ do+    let item extra =+          [("type", "Item"), ("title", "An item"), ("description", "An item."), ("timestamp", "\"2026-10-01T00:00:00Z\"")] <> extra+    accept <- memoryBundle "accept" [("items/first", item [("size", "s"), ("colour", "red")])]+    badSize <- memoryCase "item-bad-size" "size" (item [("size", "xl")])+    prepared <- first (Text.pack . show) (Sweep.checkBaseline showRender compiled (Sweep.Suite [accept] [badSize]))+    let results = sweepOutcomes [] Sweep.LegacyKinds prepared+        expect = expectOutcome results+    expect "profile/optional/size#allowedValues" Sweep.Protected+    expect "profile/optional/size#delete" (Sweep.Subsumed ["profile/optional/size#allowedValues"])+    expect "profile/optional/colour#allowedValues" Sweep.Unprotected+    expect "profile/optional/colour#delete" Sweep.AcceptanceObservableOutcome+    assertEqual (Just "acceptance-fails") (Sweep.legacyOutcome . (^. #observation) <$> lookup "profile/optional/size#delete" results)++testSweepContradiction :: IO (Either Text ())+testSweepContradiction = do+  (_, compiled) <- loadCompiledFixture "sweep/classification.dhall"+  pure $ do+    suite <- classificationSuite+    prepared <- first (Text.pack . show) (Sweep.checkBaseline showRender compiled suite)+    -- A key that erases everything claims every relaxation is inert.+    let erasesEverything = Sweep.withBehaviourKey (const (Sweep.behaviourKey compiled)) prepared+        results = sweepOutcomes [] Sweep.DefaultKinds erasesEverything+    expectOutcome results "type:Task/required/closedBy#delete" Sweep.Contradiction++testSweepExceptions :: IO (Either Text ())+testSweepExceptions = do+  (_, compiled) <- loadCompiledFixture "sweep/classification.dhall"+  pure $ do+    suite <- classificationSuite+    prepared <- first (Text.pack . show) (Sweep.checkBaseline showRender compiled suite)+    let shared = Sweep.SweepException "type:Task/optional/priority#allowedValues" (Sweep.SharedFamily "tasks") "Tested in the tasks family."+        inexpressible = Sweep.SweepException "type:Task/required/status#delete" (Sweep.OverlappingRule "type:Task/required/closedBy") "closedBy's condition needs status."+        notAGap = Sweep.SweepException "type:Task/required/closedBy#delete" (Sweep.Deferred "mori://shinzui/okf/okf/improvement-requests/concepts/IR-12") "Protected after all."+        absent = Sweep.SweepException "type:Task/optional/ghost#delete" (Sweep.SharedFamily "tasks") "No such rule."+        exceptions = [shared, inexpressible, notAGap, absent]+        results = sweepOutcomes exceptions Sweep.DefaultKinds prepared+        outcomes = [(identifier, result ^. #outcome) | (identifier, result) <- results]+    expectOutcome results "type:Task/optional/priority#allowedValues" (Sweep.ExceptionOutcome shared)+    expectOutcome results "type:Task/required/status#delete" (Sweep.ExceptionOutcome inexpressible)+    expectOutcome results "type:Task/required/closedBy#delete" Sweep.Protected+    assertEqual [notAGap, absent] (Sweep.staleExceptions Sweep.DefaultKinds False exceptions outcomes)+    assertEqual [notAGap] (Sweep.staleExceptions Sweep.DefaultKinds True exceptions outcomes)+    -- A presence exception names a kind a legacy run never enumerates.+    let presence = Sweep.SweepException "type:Task/required/ghost#presence" (Sweep.SharedFamily "tasks") "Default kinds only."+    assertEqual [] (Sweep.staleExceptions Sweep.LegacyKinds False [presence] outcomes)++testSweepMalformedExceptions :: Either Text ()+testSweepMalformedExceptions = do+  let rejected bytes = either (const True) (const False) (Sweep.parseExceptions bytes)+      entry fields = "{\"version\": 1, \"exceptions\": [{" <> fields <> "}]}"+  parsed <- Sweep.parseExceptions (entry "\"relaxation\": \"profile/required/x#delete\", \"class\": \"shared-family\", \"home\": \"okfV02\", \"rationale\": \"Spliced.\"")+  assertEqual [Sweep.SweepException "profile/required/x#delete" (Sweep.SharedFamily "okfV02") "Spliced."] parsed+  assertBool "version 2 is rejected" (rejected "{\"version\": 2, \"exceptions\": []}")+  assertBool "an unknown class is rejected" (rejected (entry "\"relaxation\": \"r\", \"class\": \"vibes\", \"rationale\": \"x\""))+  assertBool "shared-family needs home" (rejected (entry "\"relaxation\": \"r\", \"class\": \"shared-family\", \"rationale\": \"x\""))+  assertBool "overlapping-rule needs overlapsWith" (rejected (entry "\"relaxation\": \"r\", \"class\": \"overlapping-rule\", \"rationale\": \"x\""))+  assertBool "deferred needs a mori:// request" (rejected (entry "\"relaxation\": \"r\", \"class\": \"deferred\", \"request\": \"IR-3\", \"rationale\": \"x\""))+  assertBool "an empty rationale is rejected" (rejected (entry "\"relaxation\": \"r\", \"class\": \"shared-family\", \"home\": \"h\", \"rationale\": \" \""))++-- | Each erasure must leave the key equal and, on concepts that exercise the+-- erased member, the violations identical; a description on a rule with a+-- presence clause must not be erased.+testSweepBehaviourKeyErasures :: IO (Either Text ())+testSweepBehaviourKeyErasures = do+  (spec, compiled) <- loadCompiledFixture "sweep/classification.dhall"+  pure $ do+    probes <-+      traverse+        (\(rawId, fields) -> conceptFromDocument <$> parseTestConceptId rawId <*> firstShow (parseDocument (sweepDocument fields)))+        [ ("tasks/a", baseTask <> [("note", "anything"), ("parent", "TASK-1")]),+          ("tasks/b", setSweepField "docId" "TASK-2" baseTask <> [("parent", "https://example.com/tasks/1")]),+          ("tasks/c", setSweepField "docId" "TASK-3" baseTask <> [("parent", "TASK-2"), ("note", "[1, 2]")]),+          ("tasks/d", [(k, v) | (k, v) <- setSweepField "docId" "TASK-4" baseTask, k /= "title"])+        ]+    let onType f = spec & #types . traverse . #frontmatter %~ f+        onRule name f = onType (\rules -> rules & #optional . traverse . filtered ((== name) . (^. #field)) %~ f)+        withReference f = onRule "parent" (\rule -> rule & #reference . _Just %~ f)+        same label relaxed = do+          relaxedCompiled <- first (\errors -> label <> ": " <> Text.pack (show errors)) (compileProfile relaxed)+          assertBool (label <> ": behaviour key differs") (Sweep.behaviourKey relaxedCompiled == Sweep.behaviourKey compiled)+          for_ [PermissiveConformance, StrictAuthoring] $ \mode ->+            assertEqual (validateProfile mode compiled probes) (validateProfile mode relaxedCompiled probes)+        unpatterned = withReference (\policy -> policy & #externalUriSchemes .~ [] & #externalUriPattern .~ Nothing)+        patterned = withReference (\policy -> policy & #externalUriSchemes .~ [] & #externalUriPattern ?~ "https://example[.]com/.*")+    same "unconstrained optional rule in an open record" (onType (#optional %~ filter ((/= "note") . (^. #field))))+    same "description on a rule without a presence clause" (onRule "note" (#description .~ Nothing))+    same "allowSelf while allowLocal is False" (withReference (#allowSelf .~ True))+    unpatternedCompiled <- first (Text.pack . show) (compileProfile unpatterned)+    patternedCompiled <- first (Text.pack . show) (compileProfile patterned)+    assertBool "externalUriPattern without schemes is erased" (Sweep.behaviourKey unpatternedCompiled == Sweep.behaviourKey patternedCompiled)+    for_ [PermissiveConformance, StrictAuthoring] $ \mode ->+      assertEqual (validateProfile mode unpatternedCompiled probes) (validateProfile mode patternedCompiled probes)+    let describedTitle = spec & #frontmatter . #required . traverse . filtered ((== "title") . (^. #field)) . #description ?~ "Shown when title is missing."+    describedCompiled <- first (Text.pack . show) (compileProfile describedTitle)+    assertBool "a required rule's description is kept" (Sweep.behaviourKey describedCompiled /= Sweep.behaviourKey compiled)

@@ -0,0 +1,2 @@+-- Build-output directories are excluded even when they contain valid profiles.+../../profiles/decisions.dhall

@@ -0,0 +1,4 @@+# Bundle Update Log++## 2026-10-28+* **Add**: Created the sweep fixture.

@@ -0,0 +1,11 @@+---+type: Note+title: First+description: A note in the sweep fixture.+timestamp: "2026-10-01T00:00:00Z"+status: final+---++# First++A note.

@@ -0,0 +1,4 @@+{+  "note-missing-title": "title",+  "note-bad-status": "status"+}

@@ -0,0 +1,11 @@+---+type: Note+title: Bad status+description: A note in the sweep fixture.+timestamp: "2026-10-01T00:00:00Z"+status: wip+---++# Bad status++A note.

@@ -0,0 +1,10 @@+---+type: Note+description: A note in the sweep fixture.+timestamp: "2026-10-01T00:00:00Z"+status: draft+---++# x++A note.

@@ -0,0 +1,76 @@+-- Exercises every classification rule of okf profile sweep that an open+-- profile can reach: a vocabulary a condition depends on (admitValue), a+-- local-only reference whose allowLocal is masked (covered by reference), an+-- allowSelf that is never read (inert), an unconstrained optional field+-- (inert), and an untested vocabulary (unprotected or a manifest exception).+let okf = ../../../dhall/package.dhall++let Profile = okf.defaults.Profile++let TypeRule = okf.defaults.TypeRule++let FieldRule = okf.defaults.FieldRule++let FrontmatterDefaults = okf.defaults.FrontmatterRules++let HandleReferenceRule = okf.defaults.HandleReferenceRule++let Cardinality = okf.Cardinality++let FieldFormat = okf.FieldFormat++let field = okf.mk.FieldRule++in  Profile::{+    , name = "sweep-classification"+    , allowUnknownTypes = False+    , idField = Some "docId"+    , frontmatter = FrontmatterDefaults::{+      , required = [ field.plain "type", field.plain "title" ]+      }+    , types =+      [ TypeRule::{+        , type = "Task"+        , idPrefix = Some "TASK"+        , frontmatter = FrontmatterDefaults::{+          , required =+            [ FieldRule::{+              , field = "docId"+              , cardinality = Cardinality.Scalar+              , format = Some (FieldFormat.DocumentHandle "TASK")+              }+            , FieldRule::{+              , field = "status"+              , allowedValues = [ "open", "done" ]+              , cardinality = Cardinality.Scalar+              }+            , FieldRule::{+              , field = "closedBy"+              , cardinality = Cardinality.Scalar+              , when = Some { field = "status", hasValue = [ "done" ] }+              }+            ]+          , optional =+            [ FieldRule::{+              , field = "parent"+              , cardinality = Cardinality.Scalar+              , reference = Some HandleReferenceRule::{+                , localPrefix = "TASK"+                , externalUriSchemes = [ "https" ]+                , allowLocal = False+                }+              }+            , FieldRule::{+              , field = "note"+              , description = Some "Free text; checked by nothing."+              }+            , FieldRule::{+              , field = "priority"+              , allowedValues = [ "low", "high" ]+              , cardinality = Cardinality.Scalar+              }+            ]+          }+        }+      ]+    }

@@ -0,0 +1,35 @@+-- A closed profile: deleting a declaration makes an accepted key unknown, which+-- the acceptance bundle notices for the wrong reason.+let okf = ../../../dhall/package.dhall++let Profile = okf.defaults.Profile++let FieldRule = okf.defaults.FieldRule++let FrontmatterDefaults = okf.defaults.FrontmatterRules++let Cardinality = okf.Cardinality++let field = okf.mk.FieldRule++in  Profile::{+    , name = "sweep-closed"+    , allowUnknownFields = False+    , frontmatter = FrontmatterDefaults::{+      , required = [ field.plain "type", field.plain "title" ]+      , optional =+        [ field.plain "description"+        , field.plain "timestamp"+        , FieldRule::{+          , field = "size"+          , allowedValues = [ "s", "m" ]+          , cardinality = Cardinality.Scalar+          }+        , FieldRule::{+          , field = "colour"+          , allowedValues = [ "red", "blue" ]+          , cardinality = Cardinality.Scalar+          }+        ]+      }+    }

@@ -0,0 +1,39 @@+-- The smallest suite a load-bearing sweep can disagree with: two cases that+-- each notice some relaxations, and rules (type, summary) that no case tests.+let okf = ../../../dhall/package.dhall++let Profile = okf.defaults.Profile++let TypeRule = okf.defaults.TypeRule++let FieldRule = okf.defaults.FieldRule++let FrontmatterDefaults = okf.defaults.FrontmatterRules++let Cardinality = okf.Cardinality++let field = okf.mk.FieldRule++in  Profile::{+    , name = "sweep"+    , description = Some "A two-case suite for okf profile sweep."+    , allowUnknownTypes = False+    , frontmatter = FrontmatterDefaults::{+      , required = [ field.plain "type", field.plain "title" ]+      }+    , types =+      [ TypeRule::{+        , type = "Note"+        , frontmatter = FrontmatterDefaults::{+          , required =+            [ FieldRule::{+              , field = "status"+              , allowedValues = [ "draft", "final" ]+              , cardinality = Cardinality.Scalar+              }+            ]+          , optional = [ field.plain "summary" ]+          }+        }+      ]+    }