diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,48 @@ ## [Unreleased] +## [0.6.0.0] - 2026-08-11 + +### Added + +- `Okf.Query`: selecting concepts out of a walked bundle by what their + frontmatter says. `parseFieldEquals` reads a `KEY=VALUE` filter and + `parseFieldSelector` a `KEY` or `PARENT.MEMBER` path; `conceptFieldValues` + pulls the values a filter is about out of one concept, `matchesFilter` answers + one question, and `filterConcepts` answers a list of them, reading repeated + keys as any-of and different keys as all-of while preserving `walkBundle` + order. + + A filter is **existential** over a list: `tags=cli` selects a concept tagged + `[profiles, cli]`, because a person asking for `cli` wants the concepts that + mention it. A profile's closed-vocabulary check stays universal for the same + key, because there the question is whether the key may *ever* hold that value. + A nested selector reads through both shapes a profile can describe, an + object-valued key and a list of records, since OKF v0.2 permits `verified` as + either spelling. + + Matching lives here rather than in the CLI so a consumer gets it without + spawning a subprocess. +- `Okf.Query.checkFiltersAgainstProfile` checks filters against a + `CompiledProfile` and returns `FilterProfileError` values naming a key no + relevant type declares, or a value outside a closed vocabulary. It is offline + and pure: it receives a compiled profile and decides. + + A profile-declared rule is consulted **before** the core OKF key list, never + after — `status` sits in both, and the other order would exempt exactly the key + a house profile is most likely to close. A `type` filter is additionally + checked against the profile's declared type names when + `allowUnknownTypes = False`, since that is how a profile spells its + concept-type vocabulary. + +### Changed + +- **Nothing breaks in this release.** `okf-core` 0.6.0.0 is additive — one new + module, no changed type and no removed export — and the major bump only + reflects the shared version it carries with `okf-cli`, which does break. Prior + major bumps here each carried a real break, so this one is worth naming: a + consumer upgrading from 0.5.0.0 has nothing to change. + ## [0.5.0.0] - 2026-08-01 ### Added diff --git a/okf-core.cabal b/okf-core.cabal --- a/okf-core.cabal +++ b/okf-core.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: okf-core -version: 0.5.0.0 +version: 0.6.0.0 synopsis: Read, validate, index, and traverse Open Knowledge Format bundles @@ -64,6 +64,7 @@ Okf.Profile Okf.Profile.Documentation Okf.Profile.Registry + Okf.Query Okf.Trust Okf.Validation diff --git a/src/Okf/Query.hs b/src/Okf/Query.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Query.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE PackageImports #-} + +-- | Selecting concepts out of a bundle by what their frontmatter says. +-- +-- A __filter__ is one question asked of one concept: does @status@ hold +-- @accepted@, does the concept carry @completedAt@ at all, does it carry no +-- @status@. 'filterConcepts' answers a list of them at once, keeping the +-- concepts for which every question is satisfied. +-- +-- This is OKF behavior rather than a command-line concern, so it lives here +-- and not in @okf-cli@: deciding whether a concept matches @status=accepted@ is +-- the same decision for a shell pipeline, a library consumer, and an agent, and +-- none of them should have to spawn a subprocess to get it. +-- +-- Two readings are deliberately asymmetric and are worth stating up front. A +-- filter is __existential over a list__ — @tags=cli@ selects a concept tagged +-- @[profiles, cli]@ — because a person asking for @cli@ wants the concepts that +-- mention it. A profile's closed-vocabulary check is universal for the same +-- key, because there the question is "may this key ever hold that value". The +-- two never meet: 'checkFiltersAgainstProfile' checks the /filter/, and +-- 'Okf.Profile.validateProfile' checks the /bundle/. +module Okf.Query + ( FieldSelector (..), + ConceptFilter (..), + FilterParseError (..), + parseFieldSelector, + parseFieldEquals, + renderFieldSelector, + renderFilter, + renderFilterParseError, + conceptFieldValues, + scalarText, + matchesFilter, + filterConcepts, + + -- * Checking a filter against a profile + FilterProfileError (..), + checkFiltersAgainstProfile, + ) +where + +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as AesonKey +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy qualified as LazyByteString +import Data.List qualified as List +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.Vector qualified as Vector +import Okf.Bundle (Concept, conceptDocument) +import Okf.Document (OKFDocument (frontmatter), coreFrontmatterFields, frontmatterLookup) +import Okf.Prelude +-- Imported with an explicit list that leaves out the 'Cardinality' +-- constructors: two of them are named 'List' and 'Object', which would clash +-- with aeson's 'Value' constructors of the same names. +import Okf.Profile + ( CompiledProfile, + EffectiveFieldRule, + ProfileSpec, + compiledProfileBaseRules, + compiledProfileRulesForType, + compiledProfileSpec, + compiledProfileTypeNames, + fieldRuleAllowedValues, + fieldRuleElementFields, + fieldRuleObjectFields, + ) +import "generic-lens" Data.Generics.Labels () + +-- | Which frontmatter value a filter is about. +data FieldSelector + = -- | A top-level key: @status@. + TopLevelField !Text + | -- | One level of nesting: @reviews.outcome@ or @generated.by@. The first + -- component names the parent key and the second a member of the record it + -- holds, whether that record is the value itself or an element of a list. + NestedField !Text !Text + deriving stock (Generic, Eq, Ord, Show) + +-- | One question asked of a concept. +data ConceptFilter + = -- | The selected field holds this value. For a list, any element matching + -- is enough. + FieldEquals !FieldSelector !Text + | -- | The concept carries the selected field at all, with any value. + FieldPresent !FieldSelector + | -- | The concept does not carry the selected field. + FieldAbsent !FieldSelector + deriving stock (Generic, Eq, Ord, Show) + +-- | Why a filter string could not be read. +data FilterParseError + = -- | The key, or one of its dotted components, was empty. + EmptyFilterKey + | -- | A @KEY=VALUE@ argument carried no @=@ at all. Holds the original text. + MissingFilterSeparator !Text + | -- | The key nests deeper than @parent.member@. Holds the original text. + FilterKeyTooDeep !Text + deriving stock (Generic, Eq, Show) + +-- | Read a field selector such as @status@ or @reviews.outcome@. +-- +-- One level of nesting is the limit because one level is exactly what a profile +-- can describe: @elementFields@ and @objectFields@ hold +-- 'Okf.Profile.NestedFieldRule' values that never nest further. A deeper path +-- would name a place no profile can constrain, so @--profile@ checking would +-- silently stop applying below the first level. Reporting the depth as its own +-- error is friendlier than quietly reading @b.c@ as a member name. +parseFieldSelector :: Text -> Either FilterParseError FieldSelector +parseFieldSelector raw = + case Text.splitOn "." raw of + [key] + | not (Text.null key) -> Right (TopLevelField key) + [parentKey, memberKey] + | not (Text.null parentKey), + not (Text.null memberKey) -> + Right (NestedField parentKey memberKey) + components + | length components > 2 -> Left (FilterKeyTooDeep raw) + | otherwise -> Left EmptyFilterKey + +-- | Read a @KEY=VALUE@ argument into an equality filter. +-- +-- Splits on the __first__ @=@ only, so a value may itself contain one; a +-- @resource@ holding @postgres:\/\/host\/db?a=b@ is a real case. The value is +-- taken verbatim with no trimming: whitespace in a shell argument was typed +-- deliberately, and silently trimming it would make @--where 'title= '@ mean +-- something other than what it says. +parseFieldEquals :: Text -> Either FilterParseError ConceptFilter +parseFieldEquals raw = + case Text.breakOn "=" raw of + (_, rest) + | Text.null rest -> Left (MissingFilterSeparator raw) + (rawKey, rest) -> do + selector <- parseFieldSelector rawKey + pure (FieldEquals selector (Text.drop 1 rest)) + +-- | The selector in the form a user types it. +renderFieldSelector :: FieldSelector -> Text +renderFieldSelector = \case + TopLevelField key -> key + NestedField parentKey memberKey -> parentKey <> "." <> memberKey + +-- | The filter in the form a user types it, so a diagnostic can quote the +-- question back rather than guessing which flag produced it. +renderFilter :: ConceptFilter -> Text +renderFilter = \case + FieldEquals selector wanted -> renderFieldSelector selector <> "=" <> wanted + FieldPresent selector -> renderFieldSelector selector + FieldAbsent selector -> "!" <> renderFieldSelector selector + +renderFilterParseError :: FilterParseError -> Text +renderFilterParseError = \case + EmptyFilterKey -> "a frontmatter key cannot be empty" + MissingFilterSeparator raw -> "expected KEY=VALUE, got " <> raw + FilterKeyTooDeep raw -> + raw + <> " nests deeper than one level; a filter key is KEY or PARENT.MEMBER" + +-- | Every value the selected field holds in one concept, flattened. +-- +-- A list value contributes its elements rather than itself, which is what makes +-- a filter existential over lists. A nested selector reads through both shapes a +-- profile can describe — a record-valued key (@objectFields@) and a list of +-- records (@elementFields@) — because OKF v0.2 itself permits @verified@ as +-- either one bare mapping or a list of them, and a filter that worked on only +-- one spelling would be wrong for that key. +conceptFieldValues :: FieldSelector -> Concept -> [Value] +conceptFieldValues selector concept = + case selector of + TopLevelField key -> maybe [] flatten (lookupTopLevel key) + NestedField parentKey memberKey -> + case lookupTopLevel parentKey of + Just (Object parentObject) -> memberValues memberKey parentObject + Just (Array items) -> + concat [memberValues memberKey item | Object item <- Vector.toList items] + _ -> [] + where + lookupTopLevel key = frontmatterLookup key (frontmatter (conceptDocument concept)) + memberValues memberKey parentObject = + maybe [] flatten (KeyMap.lookup (AesonKey.fromText memberKey) parentObject) + flatten = \case + Array items -> Vector.toList items + value -> [value] + +-- | The scalar text a value compares as, or 'Nothing' for a value that is not a +-- scalar. +-- +-- Numbers and booleans compare as their JSON encoding, so @--where +-- usage_count=12@ matches a YAML @usage_count: 12@ and @--where verified=true@ +-- matches a YAML boolean. Aeson writes an integral number without a trailing +-- @.0@, which is what makes the first of those work. +-- +-- A container is never a scalar: a filter cannot usefully equal an array or a +-- mapping, and @Null@ is the absence of a value written down. +scalarText :: Value -> Maybe Text +scalarText value = + case value of + String text -> Just text + Number _ -> Just (jsonText value) + Bool _ -> Just (jsonText value) + Array _ -> Nothing + Object _ -> Nothing + Null -> Nothing + where + -- Lenient decoding cannot differ from strict here: the JSON encoding of a + -- number or a boolean is ASCII. It is used so that this stays total. + jsonText = + Text.Encoding.decodeUtf8Lenient . LazyByteString.toStrict . Aeson.encode + +-- | Whether one concept answers one filter. +matchesFilter :: ConceptFilter -> Concept -> Bool +matchesFilter conceptFilter concept = + case conceptFilter of + FieldEquals selector wanted -> + any ((== Just wanted) . scalarText) (conceptFieldValues selector concept) + FieldPresent selector -> not (null (conceptFieldValues selector concept)) + FieldAbsent selector -> null (conceptFieldValues selector concept) + +-- | Keep the concepts every filter accepts, in the order they arrived. +-- +-- Repeating a key means \"or\" and naming different keys means \"and\": the +-- filters are grouped, and a concept survives when at least one filter in every +-- group matches it. Repetition reads as \"either\" because that is how the +-- profile language itself expresses a set of accepted values +-- ('Okf.Profile.FieldCondition' holds an any-of list for one field), and +-- because reading it as \"and\" would make the flag useless for a scalar key, +-- which cannot equal two different strings. +-- +-- Grouping is by selector __and__ by which question is asked, so +-- @status=accepted@ together with a @status@-absent filter is an unsatisfiable +-- conjunction of two groups rather than an \"or\" that quietly accepts +-- everything. Order is 'walkBundle' order throughout: nothing here re-sorts, so +-- a filtered listing stays diffable in CI. +filterConcepts :: [ConceptFilter] -> [Concept] -> [Concept] +filterConcepts filters concepts = + filter matchesEveryGroup concepts + where + groups = + [ [candidate | candidate <- filters, filterGroupKey candidate == key] + | key <- List.nub (map filterGroupKey filters) + ] + matchesEveryGroup concept = + all (\group -> any (`matchesFilter` concept) group) groups + +-- | The group a filter joins. The leading number distinguishes the three +-- questions, so that two filters naming the same key but asking different things +-- never collapse into one any-of group. +filterGroupKey :: ConceptFilter -> (Int, FieldSelector) +filterGroupKey = \case + FieldEquals selector _ -> (0, selector) + FieldPresent selector -> (1, selector) + FieldAbsent selector -> (2, selector) + +-- | Why a profile says a filter can never select anything. +data FilterProfileError + = -- | The filter names a key no type in the profile declares. + FilterFieldNotDeclared !FieldSelector + | -- | The filter names a value outside the key's closed vocabulary. The list + -- is the vocabulary, and it is never empty. + FilterValueNotInVocabulary !FieldSelector !Text ![Text] + deriving stock (Generic, Eq, Show) + +-- | Check filters against a compiled profile, restricted to the concept types +-- the same command line selected (all of the profile's types when it selected +-- none). +-- +-- The subject here is the /question/, not the bundle. A filter is a guess about +-- what the data says, and a wrong guess is invisible: @status=acepted@ and +-- @status=withdrawn@ both select nothing, but one is a typo and the other is a +-- true statement about the corpus. A profile already knows which is which, so a +-- caller can turn what this returns into a hard error without contradicting +-- @docs\/adr\/1-profile-declared-document-ids.md@, which keeps profile +-- deviations against a /bundle/ advisory. +-- +-- Restricting to the requested types makes the check as precise as the question: +-- if the command line said @--type Note@, a key only @Improvement Request@ +-- declares really is unusable for that query. +-- +-- Offline and pure, like every other profile check: it receives a compiled +-- profile and decides, per +-- @docs\/adr\/5-compile-profile-rules-before-validation.md@. +checkFiltersAgainstProfile :: CompiledProfile -> [Text] -> [ConceptFilter] -> [FilterProfileError] +checkFiltersAgainstProfile compiled requestedTypes = concatMap checkFilter + where + checkFilter = \case + FieldEquals selector wanted -> declarationErrors selector <> valueErrors selector wanted + FieldPresent selector -> declarationErrors selector + FieldAbsent selector -> declarationErrors selector + + -- The scopes a key may be declared in: one per relevant concept type. + -- 'compiledProfileRulesForType' already merges the profile-wide rules into + -- each type's map, so a type scope is the whole rule for a concept of that + -- type and the base map is not a scope of its own. + -- + -- __Adding the base map unconditionally would silently disable every + -- per-type vocabulary.__ 'Okf.Profile.mergeVocabulary' lets a type-scope + -- vocabulary stand where the profile scope declared none, so a key declared + -- plainly profile-wide and closed on one type has an empty allowed-value + -- list in the base map and a full one in that type's map — and an empty list + -- means unconstrained, which under 'vocabularyFor' would win. The base map + -- is therefore a scope only where it can actually govern a concept: when the + -- profile declares no types at all, and when it allows types it does not + -- declare, whose concepts fall back to exactly these rules. + scopes :: [Map Text EffectiveFieldRule] + scopes + | null typeScopes = [baseRules] + | profileSpec ^. #allowUnknownTypes = baseRules : typeScopes + | otherwise = typeScopes + + baseRules = compiledProfileBaseRules compiled + typeScopes = map (compiledProfileRulesForType compiled) relevantTypes + + relevantTypes + | null requestedTypes = compiledProfileTypeNames compiled + | otherwise = requestedTypes + + -- Every rule that governs the selected key, across the scopes in play. A + -- parent declaring both nested shapes contributes from both, which is what + -- a @recordOrList@ rule means. + rulesFor :: FieldSelector -> [EffectiveFieldRule] + rulesFor = \case + TopLevelField key -> [rule | scope <- scopes, Just rule <- [Map.lookup key scope]] + NestedField parentKey memberKey -> + [ memberRule + | scope <- scopes, + Just parentRule <- [Map.lookup parentKey scope], + Just nested <- [fieldRuleObjectFields parentRule, fieldRuleElementFields parentRule], + Just memberRule <- [Map.lookup memberKey nested] + ] + + declarationErrors selector + | not (null (rulesFor selector)) = [] + | coreFieldFallback selector = [] + | otherwise = [FilterFieldNotDeclared selector] + + -- __A core OKF key is a fallback for declaration only, never an escape from + -- a vocabulary.__ A profile rule is looked for first and governs when it + -- exists; only a key no scope declares is saved from + -- 'FilterFieldNotDeclared' by being one okf owns, and then it is + -- unconstrained because nothing declared a vocabulary for it. + -- + -- Getting that order wrong destroys the feature and is easy to do. + -- @status@ is in 'coreFrontmatterFields' /and/ is the key a house profile is + -- most likely to close, so asking "is this a core key?" first would wave + -- @status=acepted@ straight through. A nested key falls back on its parent, + -- because okf owns the shape of @generated@, @verified@, and @sources@ as + -- much as it owns their names. + coreFieldFallback = \case + TopLevelField key -> Set.member key coreFrontmatterFields + NestedField parentKey _ -> Set.member parentKey coreFrontmatterFields + + -- A declared key with a closed vocabulary rejects anything outside it. + -- Otherwise, and only for @type@, the profile's declared type names are the + -- vocabulary. The vocabulary error wins when both could fire, so a profile + -- that closes @type@ with @allowedValues@ as well reports once. + valueErrors selector wanted = + case vocabularyErrors selector wanted of + [] -> conceptTypeErrors selector wanted + errors -> errors + + vocabularyErrors selector wanted = + case vocabularyFor selector of + [] -> [] + vocabulary + | wanted `elem` vocabulary -> [] + | otherwise -> [FilterValueNotInVocabulary selector wanted vocabulary] + + -- The union of the declaring scopes' vocabularies -- unless any declaring + -- scope leaves the key unconstrained, in which case nothing can be + -- rejected. That exception is not a nicety: an __empty allowed-value list + -- means unconstrained__, so taking the union without it would invent a + -- vocabulary out of one type's rule and reject values another type permits. + vocabularyFor selector = + let vocabularies = map fieldRuleAllowedValues (rulesFor selector) + in if null vocabularies || any null vocabularies + then [] + else List.nub (concat vocabularies) + + -- @type@ needs its own check because its vocabulary is not written as + -- @allowedValues@: a profile constrains concept types with type rules plus + -- the @allowUnknownTypes@ switch. Since @type@ is the one key every concept + -- carries and the most likely thing to filter on, leaving the most common + -- typo unchecked would undercut the feature. Reusing + -- 'FilterValueNotInVocabulary' rather than adding a third constructor keeps + -- the rendered message right with no special case. + conceptTypeErrors selector wanted + | selector /= TopLevelField "type" = [] + | profileSpec ^. #allowUnknownTypes = [] + | wanted `elem` typeNames = [] + | otherwise = [FilterValueNotInVocabulary selector wanted typeNames] + where + typeNames = compiledProfileTypeNames compiled + + profileSpec :: ProfileSpec + profileSpec = compiledProfileSpec compiled diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -31,6 +31,7 @@ import Okf.Profile qualified as Profile import Okf.Profile.Documentation import Okf.Profile.Registry +import Okf.Query import Okf.Trust import Okf.Validation import System.Directory @@ -270,7 +271,11 @@ testIO "nested review fixture validates records with indexed diagnostics" testNestedReviewsFixture, testIO "conditional fixture covers ADR, PostgreSQL, and review scopes" testConditionalFieldsFixture, testIO "document reference fixture covers local, external, self, and duplicate targets" testDocumentReferencesFixture, - testIO "optional-field fixture reports only the recommendation and bad values" testOptionalFieldsFixture + testIO "optional-field fixture reports only the recommendation and bad values" testOptionalFieldsFixture, + test "parseFieldEquals and parseFieldSelector read the filter grammar" testParseConceptFilters, + test "scalarText compares numbers and booleans as JSON, containers as nothing" testQueryScalarText, + testIO "filterConcepts selects over lists, nested records, presence, and absence" testFilterConceptsOverFixture, + testIO "checkFiltersAgainstProfile rejects undeclared keys and out-of-vocabulary values" testCheckFiltersAgainstProfile ] unless (and results) exitFailure @@ -6274,6 +6279,203 @@ validateInMemoryBundle :: ValidationProfile -> VersionDeclaration -> [Concept] -> [BundleValidationError] validateInMemoryBundle profile declaration concepts = validateBundle profile declaration (bundleInventoryOfConcepts concepts) concepts + +-- | The filter grammar @okf concepts@ hands to 'parseFieldEquals': one @=@, and +-- a key that is either top-level or one level deep. +testParseConceptFilters :: Either Text () +testParseConceptFilters = do + assertEqual + (Right (FieldEquals (TopLevelField "status") "accepted")) + (parseFieldEquals "status=accepted") + assertEqual + (Right (FieldEquals (NestedField "reviews" "outcome") "approved")) + (parseFieldEquals "reviews.outcome=approved") + -- Split on the first '=' only, so a value carrying its own survives intact. + assertEqual + (Right (FieldEquals (TopLevelField "resource") "postgres://host/db?a=b")) + (parseFieldEquals "resource=postgres://host/db?a=b") + -- The value is verbatim: whitespace in a shell argument was typed on purpose. + assertEqual + (Right (FieldEquals (TopLevelField "title") " ")) + (parseFieldEquals "title= ") + assertEqual (Left (MissingFilterSeparator "status")) (parseFieldEquals "status") + assertEqual (Left (FilterKeyTooDeep "a.b.c")) (parseFieldSelector "a.b.c") + assertEqual (Left EmptyFilterKey) (parseFieldSelector ".x") + assertEqual (Left EmptyFilterKey) (parseFieldSelector "reviews.") + assertEqual (Left EmptyFilterKey) (parseFieldSelector "") + -- Rendering is the inverse a diagnostic quotes back. + assertEqual "status=accepted" (renderFilter (FieldEquals (TopLevelField "status") "accepted")) + assertEqual "reviews.outcome" (renderFieldSelector (NestedField "reviews" "outcome")) + assertEqual "completedAt" (renderFilter (FieldPresent (TopLevelField "completedAt"))) + assertEqual "!status" (renderFilter (FieldAbsent (TopLevelField "status"))) + +-- | A filter compares against text, so every non-textual scalar needs a +-- spelling. Aeson writes an integral number without a trailing @.0@, which is +-- what makes @--where usage_count=12@ match a YAML @usage_count: 12@. +testQueryScalarText :: Either Text () +testQueryScalarText = do + assertEqual (Just "accepted") (scalarText (String "accepted")) + assertEqual (Just "12") (scalarText (Number 12)) + assertEqual (Just "0.5") (scalarText (Number 0.5)) + assertEqual (Just "true") (scalarText (Bool True)) + assertEqual Nothing (scalarText Null) + assertEqual Nothing (scalarText (toJSON (["a", "b"] :: [Text]))) + assertEqual Nothing (scalarText (object ["by" .= ("human:nadeem" :: Text)])) + +-- | 'filterConcepts' over the concept-filter fixture bundle, which is built so +-- that every matching shape appears exactly once: a key present on some +-- concepts and absent on another, a list-valued key with more elements than the +-- filter names, a nested key inside a list of records whose elements disagree, +-- and a nested key inside a plain record. +testFilterConceptsOverFixture :: IO (Either Text ()) +testFilterConceptsOverFixture = do + root <- fixturePath "concept-filters" + concepts <- readBundle root + pure $ do + let selected filters = renderConceptId . conceptIdOf <$> filterConcepts filters concepts + assertEqual + ["notes/scratch", "requests/alpha", "requests/beta", "requests/gamma"] + (selected []) + assertEqual ["requests/alpha"] (selected [FieldEquals (TopLevelField "status") "accepted"]) + -- Existential over a list: alpha is tagged [profiles, cli] and still matches. + assertEqual + ["requests/alpha", "requests/beta"] + (selected [FieldEquals (TopLevelField "tags") "cli"]) + -- Existential over list elements: gamma's first review is changes-requested. + assertEqual + ["requests/alpha", "requests/gamma"] + (selected [FieldEquals (NestedField "reviews" "outcome") "approved"]) + -- The other nested shape: a record-valued key rather than a list of records. + assertEqual + ["notes/scratch", "requests/beta"] + (selected [FieldEquals (NestedField "generated" "by") "human:nadeem"]) + assertEqual ["notes/scratch"] (selected [FieldAbsent (TopLevelField "status")]) + assertEqual ["requests/gamma"] (selected [FieldPresent (TopLevelField "completedAt")]) + -- A key no concept carries selects nothing, which is not an error. + assertEqual [] (selected [FieldEquals (TopLevelField "status") "withdrawn"]) + -- Repeating a key is an "or". + assertEqual + ["requests/alpha", "requests/beta"] + ( selected + [ FieldEquals (TopLevelField "status") "accepted", + FieldEquals (TopLevelField "status") "proposed" + ] + ) + -- Different keys are an "and". + assertEqual + ["requests/beta"] + ( selected + [ FieldEquals (TopLevelField "type") "Improvement Request", + FieldEquals (TopLevelField "status") "proposed" + ] + ) + -- Grouping is by question as well as key, so these two are a conjunction of + -- two groups and can never both hold. + assertEqual + [] + ( selected + [ FieldEquals (TopLevelField "status") "accepted", + FieldAbsent (TopLevelField "status") + ] + ) + +-- | A profile checks the /question/, not the bundle: a filter naming a key the +-- profile does not declare, or a value outside a closed vocabulary, can never +-- select anything, and saying so is the whole reason @okf concepts@ takes a +-- @--profile@. +testCheckFiltersAgainstProfile :: IO (Either Text ()) +testCheckFiltersAgainstProfile = do + descriptorPath <- fixtureFilePath "profiles/concept-filters.dhall" + loaded <- loadProfileFile descriptorPath + pure $ do + spec <- first ("failed to load concept-filter profile: " <>) loaded + compiled <- firstShow (compileProfile spec) + openTypes <- firstShow (compileProfile (spec & #allowUnknownTypes .~ True)) + let checkAll = checkFiltersAgainstProfile compiled [] + checkFor wantedTypes = checkFiltersAgainstProfile compiled wantedTypes + statusVocabulary = ["proposed", "accepted", "completed", "rejected"] + reviewOutcomes = ["approved", "changes-requested", "commented"] + typeNames = ["Improvement Request", "Note"] + + -- THE REGRESSION GUARD FOR THE ORDERING TRAP. 'status' is both an OKF v0.2 + -- core key ('coreFrontmatterFields' holds it) and a key this profile closes + -- with four values. A refactor that asks "is this a core key?" before "does + -- the profile declare it?" passes every other assertion in this test and + -- silently waves the headline typo straight through. + assertEqual + [FilterValueNotInVocabulary (TopLevelField "status") "acepted" statusVocabulary] + (checkAll [FieldEquals (TopLevelField "status") "acepted"]) + assertEqual [] (checkAll [FieldEquals (TopLevelField "status") "accepted"]) + + -- A key no scope declares, whatever question is asked of it. + assertEqual + [FilterFieldNotDeclared (TopLevelField "statuz")] + (checkAll [FieldEquals (TopLevelField "statuz") "x"]) + assertEqual + [FilterFieldNotDeclared (TopLevelField "statuz")] + (checkAll [FieldPresent (TopLevelField "statuz")]) + assertEqual + [FilterFieldNotDeclared (TopLevelField "statuz")] + (checkAll [FieldAbsent (TopLevelField "statuz")]) + assertEqual [] (checkAll [FieldPresent (TopLevelField "completedAt")]) + + -- A nested member's vocabulary is reached through the parent's + -- elementFields; a member declared without one accepts anything. + assertEqual + [FilterValueNotInVocabulary (NestedField "reviews" "outcome") "approvd" reviewOutcomes] + (checkAll [FieldEquals (NestedField "reviews" "outcome") "approvd"]) + assertEqual [] (checkAll [FieldEquals (NestedField "reviews" "reviewer") "anyone"]) + assertEqual + [FilterFieldNotDeclared (NestedField "reviews" "reviewr")] + (checkAll [FieldEquals (NestedField "reviews" "reviewr") "anyone"]) + -- The other nested shape: objectFields on a record-valued key. + assertEqual [] (checkAll [FieldEquals (NestedField "generated" "by") "human:nadeem"]) + + -- The core-field fallback, for a key the profile never mentions: 'timestamp' + -- is an OKF key, and okf owns the shape of 'verified' as well as its name. + assertEqual [] (checkAll [FieldEquals (TopLevelField "timestamp") "2026-08-09T00:00:00Z"]) + assertEqual [] (checkAll [FieldEquals (NestedField "verified" "by") "human:nadeem"]) + + -- 'type' has no allowedValues anywhere; its vocabulary is the profile's + -- declared type names, and only while allowUnknownTypes is False. + assertEqual + [FilterValueNotInVocabulary (TopLevelField "type") "Ghost" typeNames] + (checkAll [FieldEquals (TopLevelField "type") "Ghost"]) + assertEqual [] (checkAll [FieldEquals (TopLevelField "type") "Note"]) + assertEqual + [] + (checkFiltersAgainstProfile openTypes [] [FieldEquals (TopLevelField "type") "Ghost"]) + + -- THE REGRESSION GUARD FOR THE SCOPE TRAP. 'noteKind' is declared plainly + -- profile-wide and closed on 'Note' alone. Treating the profile-wide rules + -- as a scope of their own would see an empty allowed-value list there, read + -- it as "unconstrained", and never report anything for this key at all. + -- Asking about 'Note' specifically must report; asking about every type must + -- not, because an 'Improvement Request' really may hold any value here. + assertEqual + [FilterValueNotInVocabulary (TopLevelField "noteKind") "bogus" ["scratch", "reference"]] + (checkFor ["Note"] [FieldEquals (TopLevelField "noteKind") "bogus"]) + assertEqual [] (checkFor ["Note"] [FieldEquals (TopLevelField "noteKind") "scratch"]) + assertEqual [] (checkAll [FieldEquals (TopLevelField "noteKind") "bogus"]) + + -- Restricting to the types the command line named is a real restriction: + -- 'targetPlan' is declared only on 'Improvement Request'. + assertEqual [] (checkAll [FieldPresent (TopLevelField "targetPlan")]) + assertEqual [] (checkFor ["Improvement Request"] [FieldPresent (TopLevelField "targetPlan")]) + assertEqual + [FilterFieldNotDeclared (TopLevelField "targetPlan")] + (checkFor ["Note"] [FieldPresent (TopLevelField "targetPlan")]) + + -- Every error is reported, not only the first. + assertEqual + [ FilterValueNotInVocabulary (TopLevelField "status") "acepted" statusVocabulary, + FilterFieldNotDeclared (TopLevelField "statuz") + ] + ( checkAll + [ FieldEquals (TopLevelField "status") "acepted", + FieldEquals (TopLevelField "statuz") "x" + ] + ) fixturePath :: FilePath -> IO FilePath fixturePath name = do diff --git a/test/fixtures/concept-filters/index.md b/test/fixtures/concept-filters/index.md new file mode 100644 --- /dev/null +++ b/test/fixtures/concept-filters/index.md @@ -0,0 +1,9 @@ +--- +okf_version: "0.2" +--- + +# Subdirectories + +- [notes/](notes/index.md) +- [requests/](requests/index.md) + diff --git a/test/fixtures/concept-filters/log.md b/test/fixtures/concept-filters/log.md new file mode 100644 --- /dev/null +++ b/test/fixtures/concept-filters/log.md @@ -0,0 +1,5 @@ +# Bundle Update Log + +## 2026-08-09 + +* **Addition**: Fixture bundle for concept listing and filtering. diff --git a/test/fixtures/concept-filters/notes/index.md b/test/fixtures/concept-filters/notes/index.md new file mode 100644 --- /dev/null +++ b/test/fixtures/concept-filters/notes/index.md @@ -0,0 +1,4 @@ +# Note + +- [Scratch](scratch.md) - A concept of a different type that carries no status at all. + diff --git a/test/fixtures/concept-filters/notes/scratch.md b/test/fixtures/concept-filters/notes/scratch.md new file mode 100644 --- /dev/null +++ b/test/fixtures/concept-filters/notes/scratch.md @@ -0,0 +1,10 @@ +--- +type: Note +title: Scratch +description: A concept of a different type that carries no status at all. +generated: + by: human:nadeem + at: "2026-08-09T00:00:00Z" +--- + +# Scratch diff --git a/test/fixtures/concept-filters/requests/alpha.md b/test/fixtures/concept-filters/requests/alpha.md new file mode 100644 --- /dev/null +++ b/test/fixtures/concept-filters/requests/alpha.md @@ -0,0 +1,19 @@ +--- +type: Improvement Request +title: Alpha +description: An accepted request with two tags and one approving model review. +requestId: IR-1 +status: accepted +tags: + - profiles + - cli +generated: + by: process:fixture + at: "2026-08-09T00:00:00Z" +reviews: + - kind: model + reviewer: openai-codex + outcome: approved +--- + +# Alpha diff --git a/test/fixtures/concept-filters/requests/beta.md b/test/fixtures/concept-filters/requests/beta.md new file mode 100644 --- /dev/null +++ b/test/fixtures/concept-filters/requests/beta.md @@ -0,0 +1,14 @@ +--- +type: Improvement Request +title: Beta +description: A proposed request with one tag and no reviews. +requestId: IR-2 +status: proposed +tags: + - cli +generated: + by: human:nadeem + at: "2026-08-09T00:00:00Z" +--- + +# Beta diff --git a/test/fixtures/concept-filters/requests/gamma.md b/test/fixtures/concept-filters/requests/gamma.md new file mode 100644 --- /dev/null +++ b/test/fixtures/concept-filters/requests/gamma.md @@ -0,0 +1,20 @@ +--- +type: Improvement Request +title: Gamma +description: A completed request with a human review that asked for changes. +requestId: IR-3 +status: completed +completedAt: "2026-08-09T00:00:00Z" +generated: + by: process:fixture + at: "2026-08-09T00:00:00Z" +reviews: + - kind: human + reviewer: human:nadeem + outcome: changes-requested + - kind: model + reviewer: openai-codex + outcome: approved +--- + +# Gamma diff --git a/test/fixtures/concept-filters/requests/index.md b/test/fixtures/concept-filters/requests/index.md new file mode 100644 --- /dev/null +++ b/test/fixtures/concept-filters/requests/index.md @@ -0,0 +1,6 @@ +# Improvement Request + +- [Alpha](alpha.md) - An accepted request with two tags and one approving model review. +- [Beta](beta.md) - A proposed request with one tag and no reviews. +- [Gamma](gamma.md) - A completed request with a human review that asked for changes. + diff --git a/test/fixtures/profiles/concept-filters.dhall b/test/fixtures/profiles/concept-filters.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/profiles/concept-filters.dhall @@ -0,0 +1,106 @@ +--| House profile for the concept-filter fixture bundle. +-- +-- Mirrors the shape of the improvement-request profile this repository's own +-- `docs/improvement-requests/` bundle uses, small enough to reason about and +-- resolvable entirely from local relative imports so the test suites stay +-- offline. +-- +-- Three declarations here carry the weight of the `okf concepts --profile` +-- tests. `status` is both an OKF v0.2 core key and a profile-declared closed +-- vocabulary, which is what proves a profile rule outranks the core key list. +-- `targetPlan` is declared only on `Improvement Request`, which is what proves +-- that restricting the check to the types `--type` named is a real restriction. +-- `noteKind` is declared plainly profile-wide and closed on `Note` alone, which +-- is the shape that catches a check treating the profile-wide rules as a scope +-- of their own: there `noteKind` has an empty allowed-value list, and an empty +-- list means unconstrained. +let Profile = ../../../dhall/Profile.dhall + +let FieldRule = ../../../dhall/defaults/FieldRule.dhall + +let FrontmatterRules = ../../../dhall/defaults/FrontmatterRules.dhall + +let NestedFieldRule = ../../../dhall/defaults/NestedFieldRule.dhall + +let TypeRule = ../../../dhall/defaults/TypeRule.dhall + +let Cardinality = ../../../dhall/Cardinality.dhall + +let FieldFormat = ../../../dhall/FieldFormat.dhall + +let field = ../../../dhall/mk/FieldRule.dhall + +in { name = "concept-filters" + , description = Some + "Fixture profile for listing and filtering the concepts in a bundle." + , okfVersion = "0.2" + , frontmatter = FrontmatterRules::{ + , required = [ field.plain "type", field.plain "title" ] + , optional = + [ FieldRule::{ + , field = "status" + , allowedValues = [ "proposed", "accepted", "completed", "rejected" ] + , cardinality = Cardinality.Scalar + } + , field.documentHandle "requestId" "IR" + , field.plain "noteKind" + , field.list "tags" + , field.rfc3339Utc "completedAt" + , field.record + "generated" + { required = + [ NestedFieldRule::{ + , field = "by" + , format = Some FieldFormat.Actor + } + ] + , recommended = [] : List NestedFieldRule.Type + , optional = + [ NestedFieldRule::{ + , field = "at" + , format = Some FieldFormat.Rfc3339Utc + } + ] + } + , field.recordList + "reviews" + { required = + [ NestedFieldRule::{ + , field = "kind" + , allowedValues = [ "human", "model" ] + } + , NestedFieldRule::{ + , field = "reviewer" + , cardinality = Cardinality.Scalar + } + , NestedFieldRule::{ + , field = "outcome" + , allowedValues = + [ "approved", "changes-requested", "commented" ] + } + ] + , recommended = [] : List NestedFieldRule.Type + , optional = [] : List NestedFieldRule.Type + } + ] + } + , allowUnknownTypes = False + , allowUnknownFields = True + , idField = Some "requestId" + , requireBundleVersion = None Text + , types = + [ TypeRule::{ + , type = "Improvement Request" + , frontmatter = FrontmatterRules::{ + , optional = [ field.plain "targetPlan" ] + } + } + , TypeRule::{ + , type = "Note" + , frontmatter = FrontmatterRules::{ + , optional = [ field.enum "noteKind" [ "scratch", "reference" ] ] + } + } + ] + } + : Profile