diff --git a/profile/seihou-registry-docs.dhall b/profile/seihou-registry-docs.dhall new file mode 100644 --- /dev/null +++ b/profile/seihou-registry-docs.dhall @@ -0,0 +1,239 @@ +--| House profile for an OKF documentation bundle generated from a Seihou registry. +-- +-- A profile is a house convention, not part of the OKF standard: a bundle that +-- deviates from this descriptor is still fully OKF-conformant. What this one +-- says is what `seihou-okf-extension docs` promises about the bundles it emits, +-- so that a consumer can check a bundle it did not generate itself. +-- +-- `pathPattern` is matched against a concept ID (`modules/haskell-library`), +-- not a file path, so it carries no `.md` suffix; `*` matches exactly one +-- segment. +-- +-- The descriptor is deliberately standalone -- every type is spelled out here +-- rather than imported -- because it is embedded in the generator and written +-- into the bundle root, where a relative import out of the bundle would not +-- resolve. +let Cardinality = < Any | Scalar | List > + +let FieldFormat = + < Rfc3339Utc + | Date + | Uri + | UriWithScheme : Text + | DocumentHandle : Text + | Actor + | HumanActor + | Integer + | NonNegativeInteger + | Boolean + > + +let FieldCondition = { field : Text, hasValue : List Text } + +let HandleReferenceRule = + { localPrefix : Text + , externalUriSchemes : List Text + , allowSelf : Bool + , allowLocal : Bool + , externalUriPattern : Optional Text + } + +let PathReferenceRule = { externalUriSchemes : List Text, allowSelf : Bool } + +let NestedFieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , path : Optional PathReferenceRule + , when : Optional FieldCondition + , reference : Optional HandleReferenceRule + } + +let NestedRules = + { required : List NestedFieldRule + , recommended : List NestedFieldRule + , optional : List NestedFieldRule + } + +let FieldRule = + { field : Text + , description : Optional Text + , allowedValues : List Text + , cardinality : Cardinality + , format : Optional FieldFormat + , elementFields : Optional NestedRules + , objectFields : Optional NestedRules + , reference : Optional HandleReferenceRule + , path : Optional PathReferenceRule + , when : Optional FieldCondition + , uniqueBy : Optional Text + } + +let FrontmatterRules = + { required : List FieldRule + , recommended : List FieldRule + , optional : List FieldRule + } + +let TypeRule = + { type : Text + , description : Optional Text + , frontmatter : FrontmatterRules + , pathPattern : Optional Text + , resourceScheme : Optional Text + , requireSchemaSection : Bool + , schemaColumns : List Text + , idPrefix : Optional Text + } + +let emptyRules + : FrontmatterRules + = { required = [] : List FieldRule + , recommended = [] : List FieldRule + , optional = [] : List FieldRule + } + +let nestedScalar = + \(name : Text) -> + \(description : Text) -> + { field = name + , description = Some description + , allowedValues = [] : List Text + , cardinality = Cardinality.Scalar + , format = None FieldFormat + , path = None PathReferenceRule + , when = None FieldCondition + , reference = None HandleReferenceRule + } + +let field = + \(name : Text) -> + \(description : Text) -> + \(cardinality : Cardinality) -> + \(format : Optional FieldFormat) -> + \(objectFields : Optional NestedRules) -> + { field = name + , description = Some description + , allowedValues = [] : List Text + , cardinality + , format + , elementFields = None NestedRules + , objectFields + , reference = None HandleReferenceRule + , path = None PathReferenceRule + , when = None FieldCondition + , uniqueBy = None Text + } + +let scalar = + \(name : Text) -> + \(description : Text) -> + field name description Cardinality.Scalar (None FieldFormat) (None NestedRules) + +let versionRule = + scalar + "version" + "The version the registry catalog records for this artifact. Optional rather than required, because `seihou-registry.dhall` itself declares `version : Optional Text`; a profile that demanded it would refuse a valid registry." + +let artifactType = + \(name : Text) -> + \(description : Text) -> + \(directory : Text) -> + { type = name + , description = Some description + , frontmatter = emptyRules // { optional = [ versionRule ] } + , pathPattern = Some "${directory}/*" + , resourceScheme = Some "seihou" + , requireSchemaSection = False + , schemaColumns = [] : List Text + , idPrefix = None Text + } + +in { name = "seihou-registry-docs" + , description = Some + "Generated documentation for a Seihou registry: one concept per published module, recipe, blueprint and agent prompt, plus one describing the registry itself. Every concept names the registry artifact it was derived from through a `seihou://` resource and records the generator that produced it, so a reader can tell derived documentation from hand-written prose and can find the `.dhall` source it came from." + , okfVersion = "0.2" + , frontmatter = + emptyRules + // { required = + [ scalar "type" "Which kind of Seihou artifact this concept documents." + , scalar "title" "The artifact's name, exactly as the registry publishes it." + , scalar + "description" + "What the artifact is for. Taken from the registry catalog entry, else the artifact's own description, else synthesized." + , field + "resource" + "A `seihou:///` pointer to the artifact this concept was derived from." + Cardinality.Scalar + (Some (FieldFormat.UriWithScheme "seihou")) + (None NestedRules) + , field + "generated" + "Which producer generated this concept, per OKF specification section 5.2. Always present, because this documentation is derived rather than written." + Cardinality.Any + (None FieldFormat) + ( Some + ( emptyRules + // { required = + [ nestedScalar + "by" + "The producer actor, `seihou-okf-extension/`." + // { format = Some FieldFormat.Actor } + ] + , optional = + [ nestedScalar + "at" + "The generation time, present only when the operator passed --generated-at." + ] + , recommended = [] : List NestedFieldRule + } + ) + ) + ] + , recommended = + [ field + "tags" + "The tags the registry catalog records for this artifact." + Cardinality.List + (None FieldFormat) + (None NestedRules) + ] + , optional = + [ field + "status" + "The concept's lifecycle status, per OKF specification section 5.4." + Cardinality.Scalar + (None FieldFormat) + (None NestedRules) + ] + } + , allowUnknownTypes = False + , allowUnknownFields = True + , idField = None Text + , requireBundleVersion = Some "0.2" + , types = + [ artifactType + "SeihouModule" + "A deterministic file-generation template: variables, generation steps, shell commands, dependencies, an optional removal procedure and optional migration edges." + "modules" + , artifactType + "SeihouRecipe" + "A named composition of modules with preset variable bindings." + "recipes" + , artifactType + "SeihouBlueprint" + "An agent-driven scaffold: a prompt, optional base modules, reference files and optional agent-guided migration edges." + "blueprints" + , artifactType + "SeihouPrompt" + "A reusable agent-session template." + "prompts" + , artifactType + "SeihouRegistry" + "The registry itself: the repository publishing these artifacts, linking each of them." + "registry" + // { frontmatter = emptyRules } + ] + } diff --git a/seihou-okf-extension.cabal b/seihou-okf-extension.cabal --- a/seihou-okf-extension.cabal +++ b/seihou-okf-extension.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-okf-extension -version: 0.7.0.0 +version: 0.8.0.0 synopsis: OKF documentation extension for Seihou registries description: External Seihou extension executable for generating OKF documentation bundles @@ -16,6 +16,9 @@ copyright: (c) 2026 Nadeem Bitar category: Development build-type: Simple +-- The house profile descriptor is embedded in the library with file-embed and +-- written into every generated bundle, so it must ship in the sdist. +extra-source-files: profile/seihou-registry-docs.dhall source-repository head type: git @@ -23,6 +26,10 @@ library seihou-okf-extension-internal default-language: GHC2024 + ghc-options: + -Wall + -Werror=incomplete-patterns + default-extensions: DeriveAnyClass DuplicateRecordFields @@ -38,22 +45,32 @@ Seihou.OKF.Docs.Render Seihou.OKF.Extension Seihou.OKF.Extension.Docs + Seihou.OKF.Extension.Version + other-modules: Paths_seihou_okf_extension + autogen-modules: Paths_seihou_okf_extension build-depends: aeson >=2.1 && <3, base >=4.18 && <5, + containers >=0.6 && <1, directory >=1.3 && <2, + file-embed >=0.0.15 && <0.1, filepath >=1.4 && <2, generic-lens >=2.2 && <3, lens >=5.2 && <6, - okf-core ^>=0.1.2.0, + okf-core ^>=0.8.0.0, optparse-applicative >=0.18 && <1, - seihou-core ^>=0.7.0.0, + seihou-core ^>=0.8.0.0, + temporary >=1.3 && <2, text >=2.0 && <3, executable seihou-okf-extension default-language: GHC2024 - ghc-options: -threaded + ghc-options: + -threaded + -Wall + -Werror=incomplete-patterns + default-extensions: DeriveAnyClass DuplicateRecordFields @@ -73,6 +90,10 @@ test-suite seihou-okf-extension-test type: exitcode-stdio-1.0 default-language: GHC2024 + ghc-options: + -Wall + -Werror=incomplete-patterns + default-extensions: DeriveAnyClass DuplicateRecordFields @@ -96,8 +117,8 @@ generic-lens >=2.2 && <3, hspec >=2.11 && <3, lens >=5.2 && <6, - okf-core ^>=0.1.2.0, - seihou-core ^>=0.7.0.0, + okf-core ^>=0.8.0.0, + seihou-core ^>=0.8.0.0, seihou-okf-extension-internal, tasty >=1.4 && <2, tasty-hspec >=1.2 && <2, diff --git a/src/Seihou/OKF/Docs/Model.hs b/src/Seihou/OKF/Docs/Model.hs --- a/src/Seihou/OKF/Docs/Model.hs +++ b/src/Seihou/OKF/Docs/Model.hs @@ -3,6 +3,7 @@ DocArtifact (..), DocEntry (..), ModuleRef (..), + EntailedRef (..), DocModel (..), DocLoadError (..), loadDocModel, @@ -13,6 +14,7 @@ import Data.Generics.Labels () import Data.Text qualified as T import GHC.Generics (Generic) +import Seihou.Core.Migration (BlueprintMigration (..)) import Seihou.Core.Registry (Registry (..), RegistryEntry (..)) import Seihou.Core.Types ( AgentPrompt, @@ -20,9 +22,7 @@ Dependency, Module (..), ModuleLoadError, - ModuleName (..), Recipe (..), - RecipeName (..), depModuleNames, ) import Seihou.Dhall.Eval @@ -35,11 +35,15 @@ import System.Directory (doesFileExist) import System.FilePath (()) +-- | The kinds of concept this bundle emits. The first four are registry entry +-- kinds; 'DocRegistryKind' belongs to the single overview concept describing the +-- registry itself, and never appears as a 'DocEntry' kind. data DocKind = DocModuleKind | DocRecipeKind | DocBlueprintKind | DocPromptKind + | DocRegistryKind deriving stock (Eq, Show) data DocArtifact @@ -57,7 +61,11 @@ tags :: ![T.Text], path :: !FilePath, artifact :: !DocArtifact, - moduleRefs :: ![ModuleRef] + moduleRefs :: ![ModuleRef], + -- | Every edge this entry\'s migrations entail, flattened across the + -- entry\'s migration edges in declaration order. Empty for every kind but + -- a blueprint, which is the only artifact that can declare entailment. + entailedRefs :: ![EntailedRef] } deriving stock (Eq, Generic, Show) @@ -67,6 +75,22 @@ } deriving stock (Eq, Generic, Show) +-- | One edge of another blueprint that crossing this entry\'s edge entails. +-- +-- @resolved@ says whether the named blueprint is listed in the /same/ registry, +-- which is the only thing this bundle can link to. An entailed edge naming a +-- blueprint in another repository is normal and expected -- see +-- @docs\/adr\/0008-an-entailed-migration-edge-is-owned-by-the-blueprint-that-declares-it.md@ +-- -- and is rendered as plain labelled text rather than as a cross-link that +-- bundle validation would report as dangling. +data EntailedRef = EntailedRef + { blueprint :: !T.Text, + from :: !T.Text, + to :: !T.Text, + resolved :: !Bool + } + deriving stock (Eq, Generic, Show) + data DocModel = DocModel { repoName :: !T.Text, repoDescription :: !(Maybe T.Text), @@ -106,7 +130,8 @@ pure $ do entries <- entriesResult let moduleNames = [entry ^. #name | entry <- entries, entry ^. #kind == DocModuleKind] - resolvedEntries = map (resolveEntryRefs moduleNames) entries + blueprintNames = [entry ^. #name | entry <- entries, entry ^. #kind == DocBlueprintKind] + resolvedEntries = map (resolveEntryRefs moduleNames blueprintNames) entries Right DocModel { repoName = repoName, @@ -147,6 +172,7 @@ DocModuleKind (DocModuleArtifact artifact) (moduleRefs dependencies) + [] loadRecipeEntry :: FilePath -> RegistryEntry -> IO (Either DocLoadError DocEntry) loadRecipeEntry registryDir entry = do @@ -161,6 +187,7 @@ DocRecipeKind (DocRecipeArtifact artifact) (moduleRefs recipeModules) + [] loadBlueprintEntry :: FilePath -> RegistryEntry -> IO (Either DocLoadError DocEntry) loadBlueprintEntry registryDir entry = do @@ -168,13 +195,14 @@ result <- evalBlueprintFromFile artifactFile pure $ case result of Left err -> Left (ArtifactLoadFailed (entry ^. #name . #unModuleName) (renderModuleLoadError err)) - Right artifact@Blueprint {baseModules} -> + Right artifact@Blueprint {baseModules, migrations} -> Right $ docEntryFromRegistry entry DocBlueprintKind (DocBlueprintArtifact artifact) (moduleRefs baseModules) + (entailedRefs migrations) loadPromptEntry :: FilePath -> RegistryEntry -> IO (Either DocLoadError DocEntry) loadPromptEntry registryDir entry = do @@ -189,9 +217,10 @@ DocPromptKind (DocPromptArtifact artifact) [] + [] -docEntryFromRegistry :: RegistryEntry -> DocKind -> DocArtifact -> [ModuleRef] -> DocEntry -docEntryFromRegistry entry kind artifact refs = +docEntryFromRegistry :: RegistryEntry -> DocKind -> DocArtifact -> [ModuleRef] -> [EntailedRef] -> DocEntry +docEntryFromRegistry entry kind artifact refs entailed = DocEntry { name = entry ^. #name . #unModuleName, kind = kind, @@ -200,7 +229,8 @@ tags = entry ^. #tags, path = entry ^. #path, artifact = artifact, - moduleRefs = refs + moduleRefs = refs, + entailedRefs = entailed } moduleRefs :: [Dependency] -> [ModuleRef] @@ -209,10 +239,26 @@ | moduleName <- depModuleNames dependencies ] -resolveEntryRefs :: [T.Text] -> DocEntry -> DocEntry -resolveEntryRefs moduleNames entry = +entailedRefs :: [BlueprintMigration] -> [EntailedRef] +entailedRefs migrations = + [ EntailedRef + { blueprint = edge ^. #blueprint, + from = edge ^. #from, + to = edge ^. #to, + resolved = False + } + | BlueprintMigration {entails} <- migrations, + edge <- entails + ] + +-- | The single place that decides whether a reference points inside this +-- registry. Module references resolve against the registry\'s module names, +-- entailed edges against its blueprint names. +resolveEntryRefs :: [T.Text] -> [T.Text] -> DocEntry -> DocEntry +resolveEntryRefs moduleNames blueprintNames entry = entry & #moduleRefs .~ [ref & #resolved .~ ((ref ^. #name) `elem` moduleNames) | ref <- entry ^. #moduleRefs] + & #entailedRefs .~ [ref & #resolved .~ ((ref ^. #blueprint) `elem` blueprintNames) | ref <- entry ^. #entailedRefs] renderModuleLoadError :: ModuleLoadError -> T.Text renderModuleLoadError = T.pack . show diff --git a/src/Seihou/OKF/Docs/Render.hs b/src/Seihou/OKF/Docs/Render.hs --- a/src/Seihou/OKF/Docs/Render.hs +++ b/src/Seihou/OKF/Docs/Render.hs @@ -1,8 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} + module Seihou.OKF.Docs.Render ( conceptIdFor, + RenderOptions (..), + defaultRenderOptions, DocRenderError (..), DocBundleError (..), + builtinProfileDescriptor, + profileFileName, renderDocBundle, + checkDocProfile, writeDocBundle, ) where @@ -11,24 +18,98 @@ import Data.Aeson (Value (..)) import Data.Bifunctor (first) import Data.Either (partitionEithers) +import Data.FileEmbed (embedStringFile) import Data.Generics.Labels () +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map import Data.Text qualified as T -import Okf.Bundle (Concept, conceptFromDocument, writeBundle) +import Data.Text.IO qualified as TIO +import GHC.Generics (Generic) +import Okf.Actor (Actor (..)) +import Okf.Bundle (BundleError, Concept, bundleInventoryOfConcepts, conceptFromDocument, writeBundle) import Okf.ConceptId (ConceptId, parseConceptId, renderConceptLink) import Okf.Document qualified as Okf +import Okf.Index (VersionDeclaration (..), supportedOkfVersion, writeBundleIndexesWith) +import Okf.Profile + ( ProfileDefinitionError, + ProfileViolation, + compileProfile, + loadProfileFile, + validateProfile, + validateProfileVersion, + ) import Okf.Validation (BundleValidationError, ValidationProfile (..), validateBundle) +import Seihou.Core.Expr (renderExpr) +import Seihou.Core.Migration + ( BlueprintMigration (..), + EntailedEdge (..), + Migration (..), + MigrationOp (..), + ) import Seihou.Core.Types - ( AgentPrompt (..), + ( AgentLaunch (..), + AgentPrompt (..), Blueprint (..), BlueprintFile (..), + Command (..), + CommandVar (..), + Dependency (..), + Expr, Module (..), + PatchOp (..), + Prompt (..), + PromptGuidance (..), Recipe (..), + Removal (..), + RemovalAction (..), + RemovalStep (..), + Step (..), + Strategy (..), + Validation (..), VarDecl (..), VarExport (..), VarName (..), + VarType (..), + VarValue (..), ) import Seihou.OKF.Docs.Model +import Seihou.OKF.Extension.Version (producerActorName) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +-- | Everything the renderer needs that is not in the model: who to name as the +-- producer, whether to stamp a generation date, and how strictly to validate. +-- +-- 'generatedAt' is deliberately a value the operator supplies rather than a +-- clock reading. Nothing in the generator reads the clock, so regenerating an +-- unchanged registry produces byte-identical output. +data RenderOptions = RenderOptions + { producerVersion :: !T.Text, + generatedAt :: !(Maybe T.Text), + validationProfile :: !ValidationProfile, + -- | Where to read the house profile descriptor from. 'Nothing' means the + -- descriptor embedded in this executable. + profileSource :: !(Maybe FilePath), + -- | Whether to check the rendered concepts against that descriptor before + -- writing anything. + enforceProfile :: !Bool + } + deriving stock (Eq, Generic, Show) + +-- | Strict OKF validation and the built-in house profile enforced, with no +-- generation date, for the given producer version. +defaultRenderOptions :: T.Text -> RenderOptions +defaultRenderOptions version = + RenderOptions + { producerVersion = version, + generatedAt = Nothing, + validationProfile = StrictAuthoring, + profileSource = Nothing, + enforceProfile = True + } + data DocRenderError = InvalidDocConceptId DocKind T.Text T.Text deriving stock (Eq, Show) @@ -36,130 +117,632 @@ data DocBundleError = DocBundleRenderError DocRenderError | DocBundleValidationError BundleValidationError + | -- | Writing the bundle\'s @index.md@ files failed after the concepts were + -- written, so the bundle on disk is missing its version declaration and its + -- per-kind section indexes. + DocBundleIndexError BundleError + | -- | The house profile descriptor could not be read as a profile at all. + DocBundleProfileUnreadable T.Text + | -- | The descriptor read but does not compile to a checkable profile. + DocBundleProfileInvalid (NonEmpty ProfileDefinitionError) + | -- | The rendered concepts deviate from the house profile. + DocBundleProfileViolation ProfileViolation deriving stock (Eq, Show) +-- | The house profile descriptor, embedded so the generator never depends on +-- its own source tree at run time. It is also written into every bundle, so a +-- downstream consumer can check a bundle it did not generate. +builtinProfileDescriptor :: T.Text +builtinProfileDescriptor = $(embedStringFile "profile/seihou-registry-docs.dhall") + +-- | Where the descriptor is written inside a generated bundle. A Dhall file at +-- the bundle root is not a concept and does not disturb the bundle walk. +profileFileName :: FilePath +profileFileName = "profile.dhall" + conceptIdFor :: DocKind -> T.Text -> Either T.Text ConceptId conceptIdFor kind name = first (T.pack . show) (parseConceptId (conceptIdTextFor kind name)) -renderDocBundle :: DocModel -> Either [DocRenderError] ([Concept], [BundleValidationError]) -renderDocBundle model = - case partitionEithers (conceptFor (model ^. #repoName) <$> model ^. #entries) of +renderDocBundle :: RenderOptions -> DocModel -> Either [DocRenderError] ([Concept], [BundleValidationError]) +renderDocBundle opts model = + case partitionEithers (registryConceptFor opts model : (conceptFor opts (model ^. #repoName) <$> model ^. #entries)) of ([], concepts) -> - Right (concepts, validateBundle PermissiveConformance concepts) + Right + ( concepts, + validateBundle + (opts ^. #validationProfile) + (VersionDeclared supportedOkfVersion) + (bundleInventoryOfConcepts concepts) + concepts + ) (errors, _) -> Left errors -- | Write concepts into the output directory. This overwrites files it writes but does -- not clear unrelated files; callers that need pristine regeneration should clear the -- output directory before calling this function. -writeDocBundle :: FilePath -> DocModel -> IO (Either [DocBundleError] ()) -writeDocBundle outDir model = - case renderDocBundle model of +-- | Check rendered concepts against the house profile, before anything is +-- written. The descriptor is read from @--profile PATH@ when the operator +-- supplied one and otherwise from 'builtinProfileDescriptor', written to a +-- temporary file because okf reads a profile from a path. +-- +-- Returns @[]@ when the profile is not being enforced. +checkDocProfile :: RenderOptions -> [Concept] -> IO [DocBundleError] +checkDocProfile opts concepts + | not (opts ^. #enforceProfile) = pure [] + | otherwise = + case opts ^. #profileSource of + Just path -> checkAgainst path + Nothing -> + withSystemTempDirectory "seihou-okf-profile" $ \tmpDir -> do + let path = tmpDir profileFileName + TIO.writeFile path builtinProfileDescriptor + checkAgainst path + where + checkAgainst path = do + loaded <- loadProfileFile path + pure $ case loaded of + Left err -> [DocBundleProfileUnreadable err] + Right spec -> + case compileProfile spec of + Left definitionErrors -> [DocBundleProfileInvalid definitionErrors] + Right compiled -> + DocBundleProfileViolation + <$> ( validateProfileVersion (VersionDeclared supportedOkfVersion) compiled + <> validateProfile (opts ^. #validationProfile) compiled concepts + ) + +writeDocBundle :: RenderOptions -> FilePath -> DocModel -> IO (Either [DocBundleError] ()) +writeDocBundle opts outDir model = + case renderDocBundle opts model of Left renderErrors -> pure (Left (DocBundleRenderError <$> renderErrors)) Right (concepts, validationErrors) - | null validationErrors -> Right <$> writeBundle outDir concepts - | otherwise -> pure (Left (DocBundleValidationError <$> validationErrors)) + | not (null validationErrors) -> + pure (Left (DocBundleValidationError <$> validationErrors)) + | otherwise -> do + -- The profile is checked before a single file is written, so a bundle + -- that violates the house convention never reaches disk at all. + profileProblems <- checkDocProfile opts concepts + if not (null profileProblems) + then pure (Left profileProblems) + else do + writeBundle outDir concepts + writeProfileDescriptor opts outDir + -- Walk what was just written and lay down the root index (carrying + -- the OKF version declaration, the one place a bundle states it) + -- plus one index per subdirectory. + indexResult <- writeBundleIndexesWith (Just supportedOkfVersion) outDir + pure (first (pure . DocBundleIndexError) indexResult) -conceptFor :: T.Text -> DocEntry -> Either DocRenderError Concept -conceptFor repoName entry = +-- | Write the descriptor the bundle was checked against beside the bundle, so a +-- reader can re-run the same check with @okf validate --profile@. +writeProfileDescriptor :: RenderOptions -> FilePath -> IO () +writeProfileDescriptor opts outDir = do + createDirectoryIfMissing True outDir + descriptor <- case opts ^. #profileSource of + Nothing -> pure builtinProfileDescriptor + Just path -> TIO.readFile path + TIO.writeFile (outDir profileFileName) descriptor + +conceptFor :: RenderOptions -> T.Text -> DocEntry -> Either DocRenderError Concept +conceptFor opts repoName entry = case conceptIdFor (entry ^. #kind) (entry ^. #name) of Left err -> Left (InvalidDocConceptId (entry ^. #kind) (entry ^. #name) err) Right conceptId -> - Right (conceptFromDocument conceptId (documentFor repoName entry)) + Right (conceptFromDocument conceptId (documentFor opts repoName entry)) -documentFor :: T.Text -> DocEntry -> Okf.OKFDocument -documentFor repoName entry = +documentFor :: RenderOptions -> T.Text -> DocEntry -> Okf.OKFDocument +documentFor opts repoName entry = Okf.OKFDocument - (frontmatterFor repoName entry) - (bodyFor entry) + (frontmatterFor opts repoName entry) + (bodyFor repoName entry) -frontmatterFor :: T.Text -> DocEntry -> Okf.Frontmatter -frontmatterFor repoName entry = +frontmatterFor :: RenderOptions -> T.Text -> DocEntry -> Okf.Frontmatter +frontmatterFor opts repoName entry = maybeSetVersion - . Okf.setTags (entry ^. #tags) - . Okf.setResource (resourceFor repoName entry) + ( baseFrontmatter + opts + (typeFor (entry ^. #kind)) + (entry ^. #name) + (descriptionFor repoName entry) + (resourceFor repoName entry) + (entry ^. #tags) + ) + where + maybeSetVersion = + maybe id (\version -> Okf.setField "version" (String version)) (entry ^. #version) + +-- | The frontmatter every concept this generator emits carries: the OKF common +-- identity fields, the resource pointer back into the registry, the tags, the +-- lifecycle status, and the @generated@ provenance block that gives the concept +-- a trust tier. +baseFrontmatter :: RenderOptions -> T.Text -> T.Text -> T.Text -> T.Text -> [T.Text] -> Okf.Frontmatter +baseFrontmatter opts conceptType title description resource tags = + Okf.setGenerated generated + . Okf.setStatus Okf.Stable + . Okf.setTags tags + . Okf.setResource resource $ Okf.okfCommon Okf.OkfCommon - { Okf.commonType = typeFor (entry ^. #kind), - Okf.commonTitle = Just (entry ^. #name), - Okf.commonDescription = entry ^. #description, + { Okf.commonType = conceptType, + Okf.commonTitle = Just title, + Okf.commonDescription = Just description, Okf.commonTimestamp = Nothing } where - maybeSetVersion = - maybe id (\version -> Okf.setField "version" (String version)) (entry ^. #version) + generated = + Okf.Generated + { Okf.generatedBy = ProducerActor producerActorName (opts ^. #producerVersion), + Okf.generatedAt = opts ^. #generatedAt + } +-- | One concept describing the registry itself, so the bundle is a connected +-- graph from a single entry point rather than a flat set of artifact pages. +registryConceptFor :: RenderOptions -> DocModel -> Either DocRenderError Concept +registryConceptFor opts model = + case conceptIdFor DocRegistryKind repoName of + Left err -> Left (InvalidDocConceptId DocRegistryKind repoName err) + Right conceptId -> + Right (conceptFromDocument conceptId document) + where + repoName = model ^. #repoName + description = + case model ^. #repoDescription of + Just described | not (T.null (T.strip described)) -> described + _ -> "The `" <> repoName <> "` seihou registry." + document = + Okf.OKFDocument + ( baseFrontmatter + opts + (typeFor DocRegistryKind) + repoName + description + ("seihou://" <> repoName <> "/seihou-registry.dhall") + ["registry", "seihou"] + ) + (registryBody repoName description (model ^. #entries)) + +registryBody :: T.Text -> T.Text -> [DocEntry] -> T.Text +registryBody repoName description entries = + T.intercalate + "\n\n" + ( [ "# " <> repoName, + description, + "Every artifact below is published by the `" + <> repoName + <> "` registry and documented in its own concept." + ] + <> foldMap (uncurry (registryKindSection entries)) kindHeadings + ) + <> "\n" + where + kindHeadings = + [ (DocModuleKind, "Modules"), + (DocRecipeKind, "Recipes"), + (DocBlueprintKind, "Blueprints"), + (DocPromptKind, "Prompts") + ] + +registryKindSection :: [DocEntry] -> DocKind -> T.Text -> [T.Text] +registryKindSection entries kind heading = + case [entry | entry <- entries, entry ^. #kind == kind] of + [] -> [] + matching -> + [ section heading (T.unlines (registryEntryLink <$> matching)) + ] + +registryEntryLink :: DocEntry -> T.Text +registryEntryLink entry = + case conceptIdFor (entry ^. #kind) (entry ^. #name) of + Right conceptId -> "- " <> renderConceptLink conceptId (entry ^. #name) + Left _ -> "- `" <> entry ^. #name <> "`" + +-- | The description strict validation insists on, in three deterministic steps: +-- what the registry catalog says about the entry, then what the artifact says +-- about itself, then a synthesized sentence. Frontmatter and the body\'s opening +-- paragraph both use this, so the two can never disagree. +descriptionFor :: T.Text -> DocEntry -> T.Text +descriptionFor repoName entry = + case nonEmpty (entry ^. #description) of + Just described -> described + Nothing -> + case nonEmpty (artifactDescription (entry ^. #artifact)) of + Just described -> described + Nothing -> + "Seihou " + <> kindNoun (entry ^. #kind) + <> " `" + <> entry ^. #name + <> "` published by the `" + <> repoName + <> "` registry." + where + nonEmpty = (>>= \text -> if T.null (T.strip text) then Nothing else Just text) + +artifactDescription :: DocArtifact -> Maybe T.Text +artifactDescription (DocModuleArtifact Module {description}) = description +artifactDescription (DocRecipeArtifact Recipe {description}) = description +artifactDescription (DocBlueprintArtifact Blueprint {description}) = description +artifactDescription (DocPromptArtifact AgentPrompt {description}) = description + +kindNoun :: DocKind -> T.Text +kindNoun DocModuleKind = "module" +kindNoun DocRecipeKind = "recipe" +kindNoun DocBlueprintKind = "blueprint" +kindNoun DocPromptKind = "agent prompt" +kindNoun DocRegistryKind = "registry" + resourceFor :: T.Text -> DocEntry -> T.Text resourceFor repoName entry = "seihou://" <> repoName <> "/" <> T.pack (entry ^. #path) -bodyFor :: DocEntry -> T.Text -bodyFor entry = +bodyFor :: T.Text -> DocEntry -> T.Text +bodyFor repoName entry = T.intercalate "\n\n" - ( baseSections entry + ( baseSections repoName entry <> kindSections entry ) <> "\n" -baseSections :: DocEntry -> [T.Text] -baseSections entry = +baseSections :: T.Text -> DocEntry -> [T.Text] +baseSections repoName entry = [ "# " <> entry ^. #name, - maybe "No description provided." id (entry ^. #description) + descriptionFor repoName entry ] <> foldMap (\version -> ["**Version:** " <> version]) (entry ^. #version) +-- | The per-kind body sections. +-- +-- A section that the artifact declares nothing for is omitted entirely, so a +-- reader never wades through a page of "none declared". The four sections that +-- predate this renderer -- Dependencies, Variables, Exports for a module, +-- Composes for a recipe, Base modules and Reference files for a blueprint, +-- Agent prompt, Reference files and Tools for a prompt -- keep their +-- "nothing declared" sentence instead, because a reader who has seen them +-- before would read their absence as a rendering bug. +-- +-- Every helper below is total and deterministic: no clock, no filesystem, and +-- every 'Data.Map.Strict.Map' walked in key order. kindSections :: DocEntry -> [T.Text] kindSections entry = case entry ^. #artifact of - DocModuleArtifact Module {vars, exports} -> - [ "## Dependencies\n\n" <> renderModuleRefs "This module has no dependencies." (entry ^. #moduleRefs), - "## Variables\n\n" <> renderVarDecls vars, - "## Exports\n\n" <> renderExports exports - ] - DocRecipeArtifact _ -> - ["## Composes\n\n" <> renderModuleRefs "This recipe does not compose any modules." (entry ^. #moduleRefs)] - DocBlueprintArtifact Blueprint {prompt, files} -> - [ "## Base modules\n\n" <> renderModuleRefs "This blueprint declares no base modules." (entry ^. #moduleRefs), - "## Agent prompt\n\n" <> firstParagraph prompt, - "## Reference files\n\n" <> renderBlueprintFiles files + DocModuleArtifact Module {vars, exports, prompts, steps, commands, dependencies, removal, migrations} -> + [ section "Dependencies" (renderDependencies "This module has no dependencies." dependencies), + section "Variables" (renderVarDecls vars), + section "Exports" (renderExports exports) ] - DocPromptArtifact AgentPrompt {prompt, files, allowedTools} -> - [ "## Agent prompt\n\n" <> firstParagraph prompt, - "## Reference files\n\n" <> renderBlueprintFiles files, - "## Tools\n\n" <> maybe "No tool restrictions declared." renderTextList allowedTools + <> optionalSection "Prompts" (renderPrompts prompts) + <> optionalSection "Generation steps" (renderSteps steps) + <> optionalSection "Commands" (renderCommands commands) + <> foldMap (optionalSection "Removal" . renderRemoval) removal + <> optionalSection "Migrations" (renderMigrations migrations) + DocRecipeArtifact Recipe {modules = recipeModules, vars, prompts} -> + [section "Composes" (renderDependencies "This recipe does not compose any modules." recipeModules)] + <> optionalSection "Variables" (renderVarDecls' vars) + <> optionalSection "Prompts" (renderPrompts prompts) + DocBlueprintArtifact Blueprint {prompt, vars, prompts, baseModules, files, allowedTools, migrations, launch, versionProbe} -> + [ section "Base modules" (renderDependencies "This blueprint declares no base modules." baseModules), + section "Agent prompt" (renderAgentPrompt prompt) ] + <> optionalSection "Variables" (renderVarDecls' vars) + <> optionalSection "Prompts" (renderPrompts prompts) + <> [section "Reference files" (renderBlueprintFiles files)] + <> foldMap (optionalSection "Tools" . renderTextList') allowedTools + <> foldMap (optionalSection "Agent launch" . renderAgentLaunch) launch + <> foldMap (optionalSection "Version probe" . renderVersionProbe) versionProbe + <> optionalSection + "Migrations" + (renderBlueprintMigrations (resolvedEntailedBlueprints entry) migrations) + DocPromptArtifact AgentPrompt {prompt, vars, prompts, commandVars, guidance, files, allowedTools, launch} -> + [section "Agent prompt" (renderAgentPrompt prompt)] + <> optionalSection "Variables" (renderVarDecls' vars) + <> optionalSection "Prompts" (renderPrompts prompts) + <> optionalSection "Command variables" (renderCommandVars commandVars) + <> optionalSection "Guidance" (renderGuidance guidance) + <> [ section "Reference files" (renderBlueprintFiles files), + section "Tools" (maybe "No tool restrictions declared." renderTextList allowedTools) + ] + <> foldMap (optionalSection "Agent launch" . renderAgentLaunch) launch -renderModuleRefs :: T.Text -> [ModuleRef] -> T.Text -renderModuleRefs emptyMessage refs = - case refs of - [] -> emptyMessage - _ -> T.unlines ["- " <> moduleLink (ref ^. #name) | ref <- refs] +-- | Sections are joined with a blank line between them, so a body\'s own +-- trailing newline is stripped rather than left to open a second blank line. +section :: T.Text -> T.Text -> T.Text +section heading body = "## " <> heading <> "\n\n" <> T.stripEnd body +-- | A section that disappears when its renderer produced nothing. +optionalSection :: T.Text -> T.Text -> [T.Text] +optionalSection heading body + | T.null (T.strip body) = [] + | otherwise = [section heading body] + +-- | The blueprint names that this entry's entailed edges resolved to inside the +-- same registry. Resolution is decided once, in +-- 'Seihou.OKF.Docs.Model.resolveEntryRefs'; this only reads the answer. +resolvedEntailedBlueprints :: DocEntry -> [T.Text] +resolvedEntailedBlueprints entry = + [ref ^. #blueprint | ref <- entry ^. #entailedRefs, ref ^. #resolved] + +renderDependencies :: T.Text -> [Dependency] -> T.Text +renderDependencies emptyMessage [] = emptyMessage +renderDependencies _ dependencies = + T.unlines + [ "- " <> moduleLink (moduleName ^. #unModuleName) <> renderSuppliedVars vars + | Dependency {module_ = moduleName, vars} <- dependencies + ] + +-- | The variable bindings the composing artifact supplies along this edge. +renderSuppliedVars :: Map VarName T.Text -> T.Text +renderSuppliedVars vars + | Map.null vars = "" + | otherwise = + " (with " + <> T.intercalate + ", " + [ "`" <> varName <> "` = `" <> value <> "`" + | (VarName varName, value) <- Map.toAscList vars + ] + <> ")" + moduleLink :: T.Text -> T.Text moduleLink name = case conceptIdFor DocModuleKind name of Right conceptId -> renderConceptLink conceptId name Left _ -> "`" <> name <> "`" +-- | Variables, with the type, requiredness, default, validation rule and +-- description the declaration actually carries. renderVarDecls :: [VarDecl] -> T.Text renderVarDecls [] = "No variables declared." -renderVarDecls vars = - T.unlines ["- `" <> varName <> "`" <> requiredLabel required | VarDecl {name = VarName varName, required} <- vars] +renderVarDecls vars = renderVarDecls' vars -requiredLabel :: Bool -> T.Text -requiredLabel required - | required = " (required)" - | otherwise = "" +-- | 'renderVarDecls' without the "none declared" fallback, for the kinds whose +-- Variables section is omitted when empty. +renderVarDecls' :: [VarDecl] -> T.Text +renderVarDecls' vars = T.unlines (renderVarDecl <$> vars) +renderVarDecl :: VarDecl -> T.Text +renderVarDecl VarDecl {name = VarName varName, type_, default_, description, required, validation} = + "- `" + <> varName + <> "` — " + <> T.intercalate + ", " + ( [renderVarType type_, if required then "required" else "optional"] + <> foldMap (\value -> ["default `" <> renderValue value <> "`"]) default_ + <> foldMap (pure . renderValidation) validation + ) + <> foldMap (". " <>) description + +renderVarType :: VarType -> T.Text +renderVarType VTText = "text" +renderVarType VTBool = "boolean" +renderVarType VTInt = "integer" +renderVarType (VTList inner) = "list of " <> renderVarType inner +renderVarType (VTChoice choices) = + "one of " <> T.intercalate ", " ["`" <> choice <> "`" | choice <- choices] + +renderValidation :: Validation -> T.Text +renderValidation (ValPattern pattern_) = "matching `" <> pattern_ <> "`" +renderValidation (ValRange low high) = + "between " <> T.pack (show low) <> " and " <> T.pack (show high) +renderValidation (ValMinLength n) = "at least " <> T.pack (show n) <> " characters" +renderValidation (ValMaxLength n) = "at most " <> T.pack (show n) <> " characters" + +-- | A concrete value, in the plainest form a reader can act on. Distinct from +-- 'Seihou.Core.Expr.renderExpr', which renders values as expression syntax and +-- therefore quotes text. +renderValue :: VarValue -> T.Text +renderValue (VText text) = text +renderValue (VBool True) = "true" +renderValue (VBool False) = "false" +renderValue (VInt n) = T.pack (show n) +renderValue (VList values) = T.intercalate ", " (renderValue <$> values) + renderExports :: [VarExport] -> T.Text renderExports [] = "No exports declared." renderExports exports = - T.unlines ["- `" <> varName <> "`" | VarExport {var = VarName varName} <- exports] + T.unlines + [ "- `" <> varName <> "`" <> foldMap (\(VarName aliasName) -> " as `" <> aliasName <> "`") alias + | VarExport {var = VarName varName, alias} <- exports + ] +-- | Interactive prompts: which variable each fills, what it asks, the choices +-- it offers, and the condition that gates it. +renderPrompts :: [Prompt] -> T.Text +renderPrompts prompts = T.unlines (renderPrompt <$> prompts) + +renderPrompt :: Prompt -> T.Text +renderPrompt Prompt {var = VarName varName, text, condition, choices} = + "- `" + <> varName + <> "` — " + <> T.strip text + <> foldMap renderChoices choices + <> renderCondition condition + where + renderChoices options = + " (choices: " <> T.intercalate ", " ["`" <> option <> "`" | option <- options] <> ")" + +renderCondition :: Maybe Expr -> T.Text +renderCondition = foldMap (\expr -> " — when `" <> renderExpr expr <> "`") + +renderSteps :: [Step] -> T.Text +renderSteps steps = T.unlines (renderStep <$> steps) + +renderStep :: Step -> T.Text +renderStep Step {strategy, src, dest, condition, patch} = + "- `" + <> renderStrategy strategy + <> "` `" + <> T.pack src + <> "` → `" + <> dest + <> "`" + <> foldMap (\op -> " (" <> renderPatchOp op <> ")") patch + <> renderCondition condition + +renderStrategy :: Strategy -> T.Text +renderStrategy Copy = "Copy" +renderStrategy Template = "Template" +renderStrategy DhallText = "DhallText" +renderStrategy Structured = "Structured" + +renderPatchOp :: PatchOp -> T.Text +renderPatchOp AppendFile = "appends to a file another module owns" +renderPatchOp PrependFile = "prepends to a file another module owns" +renderPatchOp AppendSection = "appends a marked section to a file another module owns" +renderPatchOp AppendLineIfAbsent = "appends one line to a file another module owns, if absent" + +renderCommands :: [Command] -> T.Text +renderCommands commands = T.unlines (renderCommand <$> commands) + +renderCommand :: Command -> T.Text +renderCommand Command {run, workDir, condition} = + "- `" <> run <> "`" <> renderWorkDir workDir <> renderCondition condition + +renderWorkDir :: Maybe T.Text -> T.Text +renderWorkDir = foldMap (\dir -> " in `" <> dir <> "`") + +renderRemoval :: Removal -> T.Text +renderRemoval Removal {steps, commands} = + T.intercalate "\n" (filter (not . T.null) [renderRemovalSteps steps, renderRemovalCommands commands]) + where + renderRemovalSteps [] = "" + renderRemovalSteps removalSteps = T.unlines (renderRemovalStep <$> removalSteps) + renderRemovalCommands [] = "" + renderRemovalCommands removalCommands = + "Then runs:\n\n" <> T.unlines (renderCommand <$> removalCommands) + +renderRemovalStep :: RemovalStep -> T.Text +renderRemovalStep RemovalStep {action, dest, src} = + "- " <> renderRemovalAction action <> " `" <> dest <> "`" <> foldMap (\path -> " using `" <> T.pack path <> "`") src + +renderRemovalAction :: RemovalAction -> T.Text +renderRemovalAction RemoveFileAction = "delete" +renderRemovalAction RemoveSectionAction = "strip this module's section from" +renderRemovalAction RewriteFileAction = "rewrite" + +renderMigrations :: [Migration] -> T.Text +renderMigrations migrations = + T.intercalate "\n\n" (renderMigration <$> migrations) + +renderMigration :: Migration -> T.Text +renderMigration Migration {from, to, ops} = + "### " <> from <> " → " <> to <> "\n\n" <> renderMigrationOps ops + +renderMigrationOps :: [MigrationOp] -> T.Text +renderMigrationOps [] = "This edge declares no operations; it advances the recorded version only." +renderMigrationOps ops = T.unlines (renderMigrationOp <$> ops) + +renderMigrationOp :: MigrationOp -> T.Text +renderMigrationOp MoveFile {src, dest} = "- move `" <> T.pack src <> "` → `" <> T.pack dest <> "`" +renderMigrationOp MoveDir {src, dest} = "- move directory `" <> T.pack src <> "` → `" <> T.pack dest <> "`" +renderMigrationOp DeleteFile {path} = "- delete `" <> T.pack path <> "`" +renderMigrationOp DeleteDir {path} = "- delete directory `" <> T.pack path <> "`" +renderMigrationOp RunCommand {run, workDir} = + "- run `" <> run <> "`" <> foldMap (\dir -> " in `" <> T.pack dir <> "`") workDir + +-- | Blueprint migration edges, each with the guidance the agent is given and +-- the other blueprints' edges that crossing this one entails. +renderBlueprintMigrations :: [T.Text] -> [BlueprintMigration] -> T.Text +renderBlueprintMigrations resolvedBlueprints migrations = + T.intercalate "\n\n" (renderBlueprintMigration resolvedBlueprints <$> migrations) + +renderBlueprintMigration :: [T.Text] -> BlueprintMigration -> T.Text +renderBlueprintMigration resolvedBlueprints BlueprintMigration {from, to, prompt, entails} = + T.intercalate + "\n\n" + ( ["### " <> from <> " → " <> to, T.strip prompt] + <> renderEntails resolvedBlueprints entails + ) + +renderEntails :: [T.Text] -> [EntailedEdge] -> [T.Text] +renderEntails _ [] = [] +renderEntails resolvedBlueprints entails = + [ "Entails:\n\n" + <> T.unlines (renderEntailedEdge resolvedBlueprints <$> entails) + ] + +-- | An entailed edge naming a blueprint in this registry becomes a cross-link; +-- one naming a blueprint elsewhere becomes labelled text. +-- +-- The distinction is not cosmetic. An entailed edge is owned by the blueprint +-- that declares it and may legitimately name a blueprint in another repository +-- entirely (ADR 0008 in the seihou repository), and okf reports a link to a +-- concept that is not in the bundle as a dangling reference, which this +-- generator treats as fatal. +renderEntailedEdge :: [T.Text] -> EntailedEdge -> T.Text +renderEntailedEdge resolvedBlueprints EntailedEdge {blueprint, from, to} + | blueprint `elem` resolvedBlueprints, + Right conceptId <- conceptIdFor DocBlueprintKind blueprint = + "- " <> renderConceptLink conceptId blueprint <> " `" <> from <> "` → `" <> to <> "`" + | otherwise = + "- `" <> blueprint <> "` `" <> from <> "` → `" <> to <> "` (declared outside this registry)" + +renderAgentLaunch :: AgentLaunch -> T.Text +renderAgentLaunch AgentLaunch {provider, model, effort} = + case declared of + [] -> "" + _ -> + T.unlines declared + <> "\nThese are defaults. An explicit `--provider`, `--model` or `--effort` flag \ + \and the `SEIHOU_AGENT_*` environment variables both override them; the \ + \invoking user's configuration files do not.\n" + where + declared = + foldMap (\value -> ["- provider: `" <> value <> "`"]) provider + <> foldMap (\value -> ["- model: `" <> value <> "`"]) model + <> foldMap (\value -> ["- effort: `" <> value <> "`"]) effort + +renderVersionProbe :: T.Text -> T.Text +renderVersionProbe probe = + "```bash\n" + <> T.strip probe + <> "\n```\n\nSeihou reads no package-manager format of its own, so this \ + \author-declared command is how it discovers which version of this \ + \blueprint's library the project currently declares; its output supplies \ + \the default `--to` for `seihou agent migrate` (ADR 0009 in the seihou \ + \repository)." + +renderCommandVars :: [CommandVar] -> T.Text +renderCommandVars commandVars = T.unlines (renderCommandVar <$> commandVars) + +renderCommandVar :: CommandVar -> T.Text +renderCommandVar CommandVar {name = VarName varName, run, workDir, condition, trim, maxBytes} = + "- `" + <> varName + <> "` — runs `" + <> run + <> "`" + <> renderWorkDir workDir + <> ", " + <> (if trim then "trimmed" else "untrimmed") + <> foldMap (\limit -> ", capped at " <> T.pack (show limit) <> " bytes") maxBytes + <> renderCondition condition + +renderGuidance :: [PromptGuidance] -> T.Text +renderGuidance guidance = T.intercalate "\n\n" (renderGuidanceBlock <$> guidance) + +renderGuidanceBlock :: PromptGuidance -> T.Text +renderGuidanceBlock PromptGuidance {title, body, condition} = + T.intercalate + "\n\n" + ( ["### " <> title, T.strip body] + <> foldMap (\expr -> ["Applies when `" <> renderExpr expr <> "`."]) condition + ) + +-- | The prompt as a reader needs it: an opening excerpt so the section reads, +-- then the whole text verbatim in a fence so nothing is lost. +renderAgentPrompt :: T.Text -> T.Text +renderAgentPrompt prompt + | T.null (T.strip prompt) = "No prompt text provided." + | otherwise = + firstParagraph prompt <> "\n\n```text\n" <> T.strip prompt <> "\n```" + renderBlueprintFiles :: [BlueprintFile] -> T.Text renderBlueprintFiles [] = "No reference files declared." renderBlueprintFiles files = @@ -170,8 +753,11 @@ renderTextList :: [T.Text] -> T.Text renderTextList [] = "No tool restrictions declared." -renderTextList values = T.unlines ["- `" <> value <> "`" | value <- values] +renderTextList values = renderTextList' values +renderTextList' :: [T.Text] -> T.Text +renderTextList' values = T.unlines ["- `" <> value <> "`" | value <- values] + firstParagraph :: T.Text -> T.Text firstParagraph text = case T.splitOn "\n\n" text of @@ -189,9 +775,11 @@ kindDir DocRecipeKind = "recipes" kindDir DocBlueprintKind = "blueprints" kindDir DocPromptKind = "prompts" +kindDir DocRegistryKind = "registry" typeFor :: DocKind -> T.Text typeFor DocModuleKind = "SeihouModule" typeFor DocRecipeKind = "SeihouRecipe" typeFor DocBlueprintKind = "SeihouBlueprint" typeFor DocPromptKind = "SeihouPrompt" +typeFor DocRegistryKind = "SeihouRegistry" diff --git a/src/Seihou/OKF/Extension.hs b/src/Seihou/OKF/Extension.hs --- a/src/Seihou/OKF/Extension.hs +++ b/src/Seihou/OKF/Extension.hs @@ -20,8 +20,8 @@ runExtensionMain :: IO () runExtensionMain = do - command <- customExecParser (prefs showHelpOnEmpty) opts - case command of + parsedCommand <- customExecParser (prefs showHelpOnEmpty) opts + case parsedCommand of Docs docsOpts -> handleDocs docsOpts @@ -73,3 +73,31 @@ <> help "Output directory for the generated OKF bundle" ) <*> switch (long "force" <> help "Overwrite a non-empty output directory") + <*> optional + ( strOption + ( long "generated-at" + <> metavar "DATE" + <> help + "ISO-8601 date or timestamp recorded as the generation time; \ + \omitted by default so regeneration is byte-stable" + ) + ) + <*> switch + ( long "permissive" + <> help + "Validate with OKF permissive conformance instead of the default \ + \strict authoring rules" + ) + <*> optional + ( strOption + ( long "profile" + <> metavar "PATH" + <> help + "Check the bundle against this house profile descriptor instead \ + \of the built-in one" + ) + ) + <*> switch + ( long "no-profile" + <> help "Skip house-profile enforcement entirely" + ) diff --git a/src/Seihou/OKF/Extension/Docs.hs b/src/Seihou/OKF/Extension/Docs.hs --- a/src/Seihou/OKF/Extension/Docs.hs +++ b/src/Seihou/OKF/Extension/Docs.hs @@ -8,14 +8,31 @@ import Control.Lens ((^.)) import Control.Monad (when) +import Data.Aeson (Value) +import Data.Aeson.Text qualified as Aeson import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty import Data.Text qualified as T import Data.Text.IO qualified as TIO +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Builder qualified as TLB import GHC.Generics (Generic) +import Okf.Bundle (BundleError (..)) import Okf.ConceptId qualified as Okf -import Okf.Validation (BundleValidationError (..), ValidationError (..)) +import Okf.Document (DocumentParseError (..)) +import Okf.Log (LogValidationError (..)) +import Okf.Profile + ( FieldCondition (..), + FieldPath (..), + FieldPathSegment (..), + ProfileViolation (..), + renderCardinalityName, + renderFieldFormatName, + ) +import Okf.Validation (BundleValidationError (..), ValidationError (..), ValidationProfile (..)) import Seihou.OKF.Docs.Model import Seihou.OKF.Docs.Render +import Seihou.OKF.Extension.Version (extensionVersion) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, @@ -31,10 +48,33 @@ data DocsOpts = DocsOpts { dir :: !FilePath, out :: !FilePath, - force :: !Bool + force :: !Bool, + -- | Recorded verbatim as OKF @generated.at@. Absent by default, because + -- reading the clock would make every regeneration produce different bytes. + generatedAt :: !(Maybe T.Text), + -- | Validate with 'PermissiveConformance' instead of the default + -- 'StrictAuthoring'. + permissive :: !Bool, + -- | Check against this house profile descriptor instead of the built-in + -- one. + profile :: !(Maybe FilePath), + -- | Skip house-profile enforcement entirely. + noProfile :: !Bool } deriving stock (Eq, Generic, Show) +-- | The renderer configuration these command-line options describe. +renderOptionsFor :: DocsOpts -> RenderOptions +renderOptionsFor opts = + RenderOptions + { producerVersion = extensionVersion, + generatedAt = opts ^. #generatedAt, + validationProfile = + if opts ^. #permissive then PermissiveConformance else StrictAuthoring, + profileSource = opts ^. #profile, + enforceProfile = not (opts ^. #noProfile) + } + runDocs :: DocsOpts -> IO (Either T.Text T.Text) runDocs opts = do let registryFile = opts ^. #dir "seihou-registry.dhall" @@ -50,18 +90,25 @@ case modelResult of Left err -> pure (Left (renderDocLoadError err)) Right model -> - case renderDocBundle model of + case renderDocBundle (renderOptionsFor opts) model of Left renderErrors -> pure (Left (renderMany renderDocRenderError renderErrors)) Right (concepts, validationProblems) | not (null validationProblems) -> pure (Left (renderMany renderBundleValidationError validationProblems)) | otherwise -> do - prepareOutputDirectory (opts ^. #out) - writeResult <- writeDocBundle (opts ^. #out) model - pure $ case writeResult of - Left errors -> Left (renderMany renderDocBundleError errors) - Right () -> Right ("Wrote " <> T.pack (show (length concepts)) <> " concepts to " <> T.pack (opts ^. #out)) + -- Check the house profile before touching the output + -- directory, so a violating run leaves whatever was + -- there untouched rather than clearing it first. + profileProblems <- checkDocProfile (renderOptionsFor opts) concepts + if not (null profileProblems) + then pure (Left (renderMany renderDocBundleError profileProblems)) + else do + prepareOutputDirectory (opts ^. #out) + writeResult <- writeDocBundle (renderOptionsFor opts) (opts ^. #out) model + pure $ case writeResult of + Left errors -> Left (renderMany renderDocBundleError errors) + Right () -> Right ("Wrote " <> T.pack (show (length concepts)) <> " concepts to " <> T.pack (opts ^. #out)) handleDocs :: DocsOpts -> IO () handleDocs opts = do @@ -105,19 +152,73 @@ renderDocBundleError :: DocBundleError -> T.Text renderDocBundleError (DocBundleRenderError err) = renderDocRenderError err renderDocBundleError (DocBundleValidationError err) = renderBundleValidationError err +renderDocBundleError (DocBundleIndexError err) = + "failed to write bundle indexes: " <> renderBundleError err +renderDocBundleError (DocBundleProfileUnreadable err) = + "could not read the house profile descriptor: " <> err +renderDocBundleError (DocBundleProfileInvalid errs) = + "the house profile descriptor does not compile: " + <> T.intercalate "; " (T.pack . show <$> NonEmpty.toList errs) +renderDocBundleError (DocBundleProfileViolation violation) = + "house profile: " <> renderProfileViolation violation +-- | Total by construction; see 'renderBundleValidationError'. +renderBundleError :: BundleError -> T.Text +renderBundleError (InvalidConceptPath path err) = + T.pack path <> ": not a usable concept path: " <> T.pack (show err) +renderBundleError (InvalidConceptDocument path err) = + T.pack path <> ": " <> renderDocumentParseError err +renderBundleError (BundleIoError path err) = + T.pack path <> ": " <> err + +-- | Total by construction; see 'renderBundleValidationError'. +renderDocumentParseError :: DocumentParseError -> T.Text +renderDocumentParseError UnterminatedFrontmatter = + "frontmatter block is never closed" +renderDocumentParseError (InvalidYaml err) = + "frontmatter is not valid YAML: " <> err +renderDocumentParseError FrontmatterNotMapping = + "frontmatter is not a YAML mapping" + renderDocRenderError :: DocRenderError -> T.Text renderDocRenderError (InvalidDocConceptId kind name err) = "invalid OKF concept ID for " <> T.pack (show kind) <> " " <> name <> ": " <> err +-- | Every 'BundleValidationError' constructor gets its own branch, deliberately +-- with no catch-all: @-Werror=incomplete-patterns@ then turns the next okf-core +-- upgrade that adds a constructor into a build failure here rather than a +-- pattern-match crash at generation time. renderBundleValidationError :: BundleValidationError -> T.Text renderBundleValidationError (DocumentInvalid conceptId err) = Okf.renderConceptId conceptId <> ": " <> renderValidationError err renderBundleValidationError (DanglingReference source target) = Okf.renderConceptId source <> ": link to missing concept: " <> Okf.renderConceptId target +renderBundleValidationError (DanglingFrontmatterPath conceptId field target alternative) = + Okf.renderConceptId conceptId + <> ": frontmatter field " + <> field + <> " names a path that is not in the bundle: " + <> T.pack target + <> maybe "" (\alt -> " (did you mean " <> T.pack alt <> "?)") alternative renderBundleValidationError (DuplicateConceptId conceptId) = "duplicate concept ID: " <> Okf.renderConceptId conceptId +renderBundleValidationError (LogInvalid path err) = + T.pack path <> ": " <> renderLogValidationError err +renderBundleValidationError (BundleVersionUnparseable raw) = + "bundle root index declares an unparseable OKF version: " <> raw +renderBundleValidationError (BundleVersionNotUnderstood raw) = + "bundle root index declares an OKF version this tool does not understand: " <> raw +-- | Total by construction; see 'renderBundleValidationError'. +renderLogValidationError :: LogValidationError -> T.Text +renderLogValidationError (LogDateNotIso raw) = + "log day heading is not an ISO-8601 date: " <> raw +renderLogValidationError (LogDaysOutOfOrder earlier later) = + "log days are out of order: " <> earlier <> " appears before " <> later +renderLogValidationError (LogEmptyDay day) = + "log day has no entries: " <> day + +-- | Total by construction; see 'renderBundleValidationError'. renderValidationError :: ValidationError -> T.Text renderValidationError (MissingRequiredField field) = "missing required field: " <> field @@ -125,6 +226,159 @@ "field must be non-empty text: " <> field renderValidationError (MissingRecommendedField field) = "missing recommended field: " <> field +renderValidationError (FieldMustBeListOfText field) = + "field must be a list of text: " <> field +renderValidationError MissingGeneratedField = + "concept records neither a generated block nor a legacy timestamp" +renderValidationError GeneratedMustHaveActor = + "concept has a generated block with no by actor" +renderValidationError (SourceMissingResource index) = + "sources entry " <> T.pack (show index) <> " has no resource" +renderValidationError (DuplicateSourceId sourceId) = + "two sources entries share the id: " <> sourceId +renderValidationError (FootnoteLabelNotInSources label) = + "body cites footnote label with no matching sources entry: " <> label +renderValidationError (SourceIdNotCited sourceId) = + "sources entry is never cited in the body: " <> sourceId +renderValidationError (LegacyFieldInDeclaredV2 field) = + "concept uses the superseded OKF v0.1 field " <> field <> " in a bundle declaring v0.2" +renderValidationError AttestedComputationMissingRuntime = + "Attested Computation concept declares no runtime" +renderValidationError AttestedComputationHasNoComputation = + "Attested Computation concept offers neither a computation path nor a body code block" +renderValidationError AttestedComputationHasBothComputations = + "Attested Computation concept offers both a computation path and a body code block" +renderValidationError (AttestedComputationHasManyBlocks count) = + "Attested Computation section holds " + <> T.pack (show count) + <> " code blocks; exactly one is permitted" renderMany :: (a -> T.Text) -> [a] -> T.Text renderMany render = T.intercalate "\n" . fmap render + +-- | Render one house-profile deviation. +-- +-- okf-core reports 'ProfileViolation' but does not render it: the renderer +-- lives in the @okf-cli@ package, which this repository does not depend on. +-- Total by construction, for the reason 'renderBundleValidationError' gives. +renderProfileViolation :: ProfileViolation -> T.Text +renderProfileViolation (TypeNotInProfile conceptId conceptType) = + at conceptId <> "type " <> conceptType <> " is not one this profile declares" +renderProfileViolation (MissingProfileField conceptId key condition) = + at conceptId <> "missing required field " <> key <> renderFieldCondition condition +renderProfileViolation (MissingRecommendedProfileField conceptId key condition) = + at conceptId <> "missing recommended field " <> key <> renderFieldCondition condition +renderProfileViolation (MissingNestedProfileField conceptId path condition) = + at conceptId <> "missing required field " <> renderFieldPath path <> renderFieldCondition condition +renderProfileViolation (MissingRecommendedNestedProfileField conceptId path condition) = + at conceptId <> "missing recommended field " <> renderFieldPath path <> renderFieldCondition condition +renderProfileViolation (ValueNotInVocabulary conceptId path allowed value) = + at conceptId + <> renderFieldPath path + <> " holds " + <> renderJson value + <> ", which is not one of " + <> T.intercalate ", " allowed +renderProfileViolation (CardinalityMismatch conceptId path cardinality value) = + at conceptId + <> renderFieldPath path + <> " must be " + <> renderCardinalityName cardinality + <> ", but holds " + <> renderJson value +renderProfileViolation (ValueFormatMismatch conceptId path format value) = + at conceptId + <> renderFieldPath path + <> " must be " + <> renderFieldFormatName format + <> ", but holds " + <> renderJson value +renderProfileViolation (DanglingHandleReference conceptId path handle) = + at conceptId <> renderFieldPath path <> " references handle " <> handle <> ", which nothing in this bundle owns" +renderProfileViolation (ReferenceHandlePrefixMismatch conceptId path expected actual) = + at conceptId <> renderFieldPath path <> " expects handle prefix " <> expected <> ", but holds " <> actual +renderProfileViolation (MalformedDocumentReference conceptId path value) = + at conceptId <> renderFieldPath path <> " is neither a local handle nor an absolute URI: " <> renderJson value +renderProfileViolation (ExternalReferenceSchemeNotAllowed conceptId path scheme allowed) = + at conceptId + <> renderFieldPath path + <> " uses URI scheme " + <> scheme + <> ", which this profile does not permit; allowed: " + <> T.intercalate ", " allowed +renderProfileViolation (LocalDocumentReferenceNotAllowed conceptId path handle) = + at conceptId <> renderFieldPath path <> " may not hold a local handle, but holds " <> handle +renderProfileViolation (ExternalReferencePatternMismatch conceptId path value pattern_) = + at conceptId <> renderFieldPath path <> " holds " <> value <> ", which does not match " <> pattern_ +renderProfileViolation (SelfDocumentReference conceptId path value) = + at conceptId <> renderFieldPath path <> " references the concept it is written on: " <> value +renderProfileViolation (MalformedPathReference conceptId path value) = + at conceptId <> renderFieldPath path <> " is not a usable path or URI: " <> renderJson value +renderProfileViolation (PathEscapesBundle conceptId path value) = + at conceptId <> renderFieldPath path <> " climbs above the bundle root: " <> value +renderProfileViolation (DanglingPathReference conceptId path target) = + at conceptId <> renderFieldPath path <> " names a path that is not in this bundle: " <> target +renderProfileViolation (FieldNotInProfile conceptId key) = + at conceptId <> "field " <> key <> " is not one this profile declares" +renderProfileViolation (NestedElementNotRecord conceptId path value) = + at conceptId <> renderFieldPath path <> " must be a record, but holds " <> renderJson value +renderProfileViolation (DuplicateNestedFieldValue conceptId path value indexes) = + at conceptId + <> renderFieldPath path + <> " repeats the value " + <> renderJson value + <> " at elements " + <> T.intercalate ", " (T.pack . show <$> NonEmpty.toList indexes) +renderProfileViolation (PathPatternMismatch conceptId conceptType pattern_) = + at conceptId <> conceptType <> " concepts must live at " <> pattern_ +renderProfileViolation (MissingResource conceptId conceptType scheme) = + at conceptId <> conceptType <> " concepts must carry a " <> scheme <> ": resource" +renderProfileViolation (ResourceSchemeMismatch conceptId scheme resource) = + at conceptId <> "resource must use the " <> scheme <> " scheme, but is " <> resource +renderProfileViolation (MissingSchemaSection conceptId conceptType) = + at conceptId <> conceptType <> " concepts must carry a # Schema section" +renderProfileViolation (SchemaColumnsMismatch conceptId conceptType expected actual) = + at conceptId + <> conceptType + <> " # Schema columns must be " + <> T.intercalate ", " expected + <> ", but are " + <> T.intercalate ", " actual +renderProfileViolation (MissingDocumentId conceptId conceptType prefix) = + at conceptId <> conceptType <> " concepts must carry a " <> prefix <> "-N handle" +renderProfileViolation (MalformedDocumentId conceptId prefix value) = + at conceptId <> "handle " <> value <> " is not well formed for prefix " <> prefix +renderProfileViolation (DuplicateDocumentId handle conceptId other) = + "handle " + <> handle + <> " is claimed by both " + <> Okf.renderConceptId conceptId + <> " and " + <> Okf.renderConceptId other +renderProfileViolation (RequiredBundleVersionUnmet required declared) = + "bundle must declare OKF version " + <> required + <> " or later, but declares " + <> maybe "nothing" id declared + +at :: Okf.ConceptId -> T.Text +at conceptId = Okf.renderConceptId conceptId <> ": " + +renderFieldCondition :: Maybe FieldCondition -> T.Text +renderFieldCondition = + foldMap + ( \FieldCondition {field, hasValue} -> + " (required when " <> field <> " is " <> T.intercalate " or " hasValue <> ")" + ) + +-- | A frontmatter field path, in the dotted form the descriptor writes it in. +renderFieldPath :: FieldPath -> T.Text +renderFieldPath FieldPath {segments} = + T.intercalate "." (renderFieldPathSegment <$> NonEmpty.toList segments) + +renderFieldPathSegment :: FieldPathSegment -> T.Text +renderFieldPathSegment (FieldName name) = name +renderFieldPathSegment (ArrayIndex index) = "[" <> T.pack (show index) <> "]" + +renderJson :: Value -> T.Text +renderJson = TL.toStrict . TLB.toLazyText . Aeson.encodeToTextBuilder diff --git a/src/Seihou/OKF/Extension/Version.hs b/src/Seihou/OKF/Extension/Version.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/OKF/Extension/Version.hs @@ -0,0 +1,23 @@ +-- | The extension's own version, read from Cabal rather than a hand-maintained +-- literal, so the provenance actor stamped on every generated concept cannot +-- drift from the package that produced it. +module Seihou.OKF.Extension.Version + ( extensionVersion, + producerActorName, + ) +where + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Version (showVersion) +import Paths_seihou_okf_extension qualified as Paths + +-- | The extension's package version, e.g. @"0.7.0.0"@. +extensionVersion :: Text +extensionVersion = T.pack (showVersion Paths.version) + +-- | The producer half of the OKF @generated.by@ actor. The version half is +-- 'extensionVersion'; together okf renders them as +-- @seihou-okf-extension\/\@. +producerActorName :: Text +producerActorName = "seihou-okf-extension" diff --git a/test/Seihou/OKF/Docs/ModelSpec.hs b/test/Seihou/OKF/Docs/ModelSpec.hs --- a/test/Seihou/OKF/Docs/ModelSpec.hs +++ b/test/Seihou/OKF/Docs/ModelSpec.hs @@ -25,7 +25,7 @@ (model ^. #repoName) `shouldBe` "fixture-registry" length (entriesByKind DocModuleKind model) `shouldBe` 3 length (entriesByKind DocRecipeKind model) `shouldBe` 1 - length (entriesByKind DocBlueprintKind model) `shouldBe` 1 + length (entriesByKind DocBlueprintKind model) `shouldBe` 2 length (entriesByKind DocPromptKind model) `shouldBe` 1 it "keeps catalog metadata from the registry entry" $ do @@ -57,6 +57,44 @@ (recipe ^. #moduleRefs) `shouldMatchList` [ModuleRef "base" True, ModuleRef "app" True] (blueprint ^. #moduleRefs) `shouldBe` [ModuleRef "base" True] + it "resolves an entailed edge naming a blueprint in the same registry" $ do + withFixtureRegistry $ \registryDir -> do + model <- shouldLoad registryDir + let entry = requireEntry "entailing-blueprint" model + (entry ^. #entailedRefs) + `shouldContain` [ EntailedRef + { blueprint = "app-blueprint", + from = "1.0.0", + to = "2.0.0", + resolved = True + } + ] + + it "leaves an entailed edge naming a blueprint outside the registry unresolved" $ do + withFixtureRegistry $ \registryDir -> do + model <- shouldLoad registryDir + let entry = requireEntry "entailing-blueprint" model + (entry ^. #entailedRefs) + `shouldContain` [ EntailedRef + { blueprint = "kiroku", + from = "1.9.0", + to = "2.0.0", + resolved = False + } + ] + + it "records no entailed edges for a blueprint that declares none" $ do + withFixtureRegistry $ \registryDir -> do + model <- shouldLoad registryDir + (requireEntry "app-blueprint" model ^. #entailedRefs) `shouldBe` [] + + it "records no entailed edges for kinds that cannot declare them" $ do + withFixtureRegistry $ \registryDir -> do + model <- shouldLoad registryDir + (requireEntry "app" model ^. #entailedRefs) `shouldBe` [] + (requireEntry "app-recipe" model ^. #entailedRefs) `shouldBe` [] + (requireEntry "review" model ^. #entailedRefs) `shouldBe` [] + it "returns RegistryNotFound when the registry file is absent" $ do withSystemTempDirectory "seihou-doc-model-missing" $ \registryDir -> do result <- loadDocModel registryDir @@ -94,6 +132,7 @@ writeModule registryDir "modules/dangling" "dangling" ["missing"] "Dangling module" writeRecipe registryDir writeBlueprint registryDir + writeEntailingBlueprint registryDir writePrompt registryDir writeModule :: FilePath -> FilePath -> String -> [String] -> String -> IO () @@ -113,6 +152,14 @@ createDirectoryIfMissing True (registryDir relDir) writeFile (registryDir relDir "blueprint.dhall") blueprintDhall +-- | A blueprint whose one migration edge entails two edges: one of a blueprint +-- listed in this registry, and one of a blueprint that is not. +writeEntailingBlueprint :: FilePath -> IO () +writeEntailingBlueprint registryDir = do + let relDir = "blueprints/entailing-blueprint" + createDirectoryIfMissing True (registryDir relDir) + writeFile (registryDir relDir "blueprint.dhall") entailingBlueprintDhall + writePrompt :: FilePath -> IO () writePrompt registryDir = do let relDir = "prompts/review" @@ -129,7 +176,10 @@ \ , { name = \"dangling\", version = None Text, path = \"modules/dangling\", description = Some \"Dangling module\", tags = [] : List Text }\n\ \ ]\n\ \, recipes = [ { name = \"app-recipe\", version = Some \"0.1.0\", path = \"recipes/app-recipe\", description = Some \"Recipe\", tags = [ \"recipe\" ] } ]\n\ - \, blueprints = [ { name = \"app-blueprint\", version = Some \"0.1.0\", path = \"blueprints/app-blueprint\", description = Some \"Blueprint\", tags = [ \"blueprint\" ] } ]\n\ + \, blueprints =\n\ + \ [ { name = \"app-blueprint\", version = Some \"0.1.0\", path = \"blueprints/app-blueprint\", description = Some \"Blueprint\", tags = [ \"blueprint\" ] }\n\ + \ , { name = \"entailing-blueprint\", version = Some \"0.1.0\", path = \"blueprints/entailing-blueprint\", description = Some \"Entailing blueprint\", tags = [] : List Text }\n\ + \ ]\n\ \, prompts = [ { name = \"review\", version = Some \"0.1.0\", path = \"prompts/review\", description = Some \"Review prompt\", tags = [ \"prompt\" ] } ]\n\ \}" @@ -194,6 +244,36 @@ <> "\n\ \, allowedTools = None (List Text)\n\ \, tags = [ \"blueprint\" ]\n\ + \}" + +entailingBlueprintDhall :: String +entailingBlueprintDhall = + "{ name = \"entailing-blueprint\"\n\ + \, version = Some \"0.1.0\"\n\ + \, description = Some \"Entailing blueprint\"\n\ + \, prompt = \"Upgrade\"\n\ + \, vars = [] : " + <> varDeclListType + <> "\n\ + \, prompts = [] : " + <> promptListType + <> "\n\ + \, baseModules = [] : List Text\n\ + \, files = [] : " + <> blueprintFileListType + <> "\n\ + \, allowedTools = None (List Text)\n\ + \, tags = [] : List Text\n\ + \, migrations =\n\ + \ [ { from = \"2.4.0\"\n\ + \ , to = \"3.0.0\"\n\ + \ , prompt = \"Cross it\"\n\ + \ , entails =\n\ + \ [ { blueprint = \"app-blueprint\", from = \"1.0.0\", to = \"2.0.0\" }\n\ + \ , { blueprint = \"kiroku\", from = \"1.9.0\", to = \"2.0.0\" }\n\ + \ ]\n\ + \ }\n\ + \ ]\n\ \}" promptDhall :: String diff --git a/test/Seihou/OKF/Docs/RenderSpec.hs b/test/Seihou/OKF/Docs/RenderSpec.hs --- a/test/Seihou/OKF/Docs/RenderSpec.hs +++ b/test/Seihou/OKF/Docs/RenderSpec.hs @@ -1,13 +1,19 @@ module Seihou.OKF.Docs.RenderSpec (tests) where -import Control.Lens ((^.)) +import Control.Lens ((&), (?~), (^.)) import Data.Generics.Labels () import Data.List (sort) import Data.Map.Strict qualified as Map import Data.Text qualified as T import Okf.Bundle qualified as Okf import Okf.ConceptId qualified as Okf -import Okf.Validation (BundleValidationError (..)) +import Okf.Validation (BundleValidationError (..), ValidationProfile (..)) +import Seihou.Core.Migration + ( BlueprintMigration (..), + EntailedEdge (..), + Migration (..), + MigrationOp (..), + ) import Seihou.Core.Types import Seihou.OKF.Docs.Model import Seihou.OKF.Docs.Render @@ -21,19 +27,20 @@ spec :: Spec spec = do describe "renderDocBundle" $ do - it "emits one concept per entry with the documented id scheme" $ do - let Right (concepts, problems) = renderDocBundle wellFormedModel + it "emits one concept per entry, plus the registry overview, with the documented id scheme" $ do + (concepts, problems) <- renderOrFail testOptions wellFormedModel problems `shouldBe` [] sort (Okf.renderConceptId . Okf.conceptIdOf <$> concepts) `shouldBe` [ "blueprints/app-blueprint", "modules/app", "modules/base", "prompts/review", - "recipes/app-recipe" + "recipes/app-recipe", + "registry/fixture" ] it "renders frontmatter fields and resource pointers" $ do - concept <- requireConcept "modules/base" wellFormedModel + concept <- requireConcept "modules/base" testOptions wellFormedModel let rendered = Okf.serializeConcept concept rendered `shouldSatisfy` T.isInfixOf "type: SeihouModule" rendered `shouldSatisfy` T.isInfixOf "title: base" @@ -41,35 +48,219 @@ rendered `shouldSatisfy` T.isInfixOf "version: 1.0.0" it "renders resolvable cross-links to composed modules" $ do - concept <- requireConcept "recipes/app-recipe" wellFormedModel + concept <- requireConcept "recipes/app-recipe" testOptions wellFormedModel let rendered = Okf.serializeConcept concept rendered `shouldSatisfy` T.isInfixOf "](/modules/base.md)" rendered `shouldSatisfy` T.isInfixOf "](/modules/app.md)" it "validates clean for a well-formed model" $ do - let Right (_, problems) = renderDocBundle wellFormedModel + (_, problems) <- renderOrFail testOptions wellFormedModel problems `shouldBe` [] it "reports a DanglingReference for an unresolved module ref" $ do - let Right (_, problems) = renderDocBundle danglingModel + (_, problems) <- renderOrFail testOptions danglingModel problems `shouldSatisfy` any isDanglingReference it "reports invalid generated concept IDs as render errors" $ do - renderDocBundle invalidIdModel + renderDocBundle testOptions invalidIdModel `shouldBe` Left [InvalidDocConceptId DocModuleKind "-bad" "InvalidConceptIdSegment \"-bad\""] -requireConcept :: T.Text -> DocModel -> IO Okf.Concept -requireConcept rawId model = - case renderDocBundle model of + it "stamps a generated.by producer actor on every concept" $ do + (concepts, _) <- renderOrFail testOptions wellFormedModel + let rendered = Okf.serializeConcept <$> concepts + rendered `shouldSatisfy` all (T.isInfixOf "by: seihou-okf-extension/9.9.9") + + it "omits generated.at unless the operator supplies one" $ do + concept <- requireConcept "modules/base" testOptions wellFormedModel + Okf.serializeConcept concept `shouldNotSatisfy` T.isInfixOf "at:" + + it "records --generated-at verbatim in generated.at" $ do + let dated = testOptions & #generatedAt ?~ "2026-09-10" + concept <- requireConcept "modules/base" dated wellFormedModel + Okf.serializeConcept concept `shouldSatisfy` T.isInfixOf "at: 2026-09-10" + + it "marks every concept stable" $ do + concept <- requireConcept "modules/base" testOptions wellFormedModel + Okf.serializeConcept concept `shouldSatisfy` T.isInfixOf "status: stable" + + it "validates clean under StrictAuthoring when nothing supplies a description" $ do + (_, problems) <- renderOrFail testOptions undescribedModel + problems `shouldBe` [] + + it "falls back to the artifact description when the registry entry has none" $ do + concept <- requireConcept "modules/base" testOptions registrySilentModel + Okf.serializeConcept concept + `shouldSatisfy` T.isInfixOf "description: the artifact describes itself" + + it "synthesizes a description when neither the registry nor the artifact has one" $ do + concept <- requireConcept "modules/base" testOptions undescribedModel + Okf.serializeConcept concept + `shouldSatisfy` T.isInfixOf "Seihou module `base` published by the `fixture` registry." + + describe "artifact features" $ do + it "renders a variable declaration in full" $ do + body <- requireBody "modules/rich" testOptions richModel + body `shouldSatisfy` T.isInfixOf "- `project.name` — text, required, matching `[a-z]+`. The project name" + body `shouldSatisfy` T.isInfixOf "- `license` — one of `MIT`, `BSD-3`, optional, default `MIT`" + body `shouldSatisfy` T.isInfixOf "- `retries` — integer, optional, between 0 and 5" + + it "renders an export alias" $ do + body <- requireBody "modules/rich" testOptions richModel + body `shouldSatisfy` T.isInfixOf "- `project.name` as `app.name`" + + it "renders interactive prompts with choices and conditions" $ do + body <- requireBody "modules/rich" testOptions richModel + body `shouldSatisfy` T.isInfixOf "## Prompts" + body + `shouldSatisfy` T.isInfixOf + "- `license` — Which license? (choices: `MIT`, `BSD-3`) — when `IsSet project.name`" + + it "renders generation steps with strategy, patch operation and condition" $ do + body <- requireBody "modules/rich" testOptions richModel + body `shouldSatisfy` T.isInfixOf "## Generation steps" + body `shouldSatisfy` T.isInfixOf "- `Template` `flake.nix.tpl` → `flake.nix`" + body + `shouldSatisfy` T.isInfixOf + "- `Copy` `gitignore.tpl` → `.gitignore` (appends one line to a file another module owns, if absent) — when `Eq license \"MIT\"`" + + it "renders commands with working directory and condition" $ do + body <- requireBody "modules/rich" testOptions richModel + body `shouldSatisfy` T.isInfixOf "## Commands" + body `shouldSatisfy` T.isInfixOf "- `cabal build` in `app` — when `IsSet license`" + + it "renders the removal procedure" $ do + body <- requireBody "modules/rich" testOptions richModel + body `shouldSatisfy` T.isInfixOf "## Removal" + body `shouldSatisfy` T.isInfixOf "- delete `flake.nix`" + body `shouldSatisfy` T.isInfixOf "- strip this module's section from `.gitignore`" + body `shouldSatisfy` T.isInfixOf "Then runs:" + body `shouldSatisfy` T.isInfixOf "- `rm -rf dist-newstyle`" + + it "renders each module migration edge with its operations" $ do + body <- requireBody "modules/rich" testOptions richModel + body `shouldSatisfy` T.isInfixOf "## Migrations" + body `shouldSatisfy` T.isInfixOf "### 0.1.0 → 0.2.0" + body `shouldSatisfy` T.isInfixOf "- move `old.nix` → `new.nix`" + body `shouldSatisfy` T.isInfixOf "### 0.2.0 → 0.3.0" + body `shouldSatisfy` T.isInfixOf "- delete directory `legacy`" + body `shouldSatisfy` T.isInfixOf "- run `just fmt` in `." + + it "omits sections the module declares nothing for" $ do + body <- requireBody "modules/base" testOptions wellFormedModel + body `shouldNotSatisfy` T.isInfixOf "## Migrations" + body `shouldNotSatisfy` T.isInfixOf "## Removal" + body `shouldNotSatisfy` T.isInfixOf "## Generation steps" + + it "shows the variable bindings a recipe supplies along each edge" $ do + body <- requireBody "recipes/rich-recipe" testOptions richModel + body `shouldSatisfy` T.isInfixOf "(with `license` = `MIT`, `project.name` = `demo`)" + + it "links an entailed edge whose blueprint is in the same registry" $ do + body <- requireBody "blueprints/rich-blueprint" testOptions richModel + body `shouldSatisfy` T.isInfixOf "Entails:" + body `shouldSatisfy` T.isInfixOf "- [other-blueprint](/blueprints/other-blueprint.md) `1.9.0` → `2.0.0`" + + it "labels an entailed edge whose blueprint is outside the registry" $ do + body <- requireBody "blueprints/rich-blueprint" testOptions richModel + body `shouldSatisfy` T.isInfixOf "- `kiroku` `1.9.0` → `2.0.0` (declared outside this registry)" + + it "does not turn an out-of-registry entailed edge into a dangling reference" $ do + (_, problems) <- renderOrFail testOptions richModel + problems `shouldBe` [] + + it "renders blueprint launch preferences and says what overrides them" $ do + body <- requireBody "blueprints/rich-blueprint" testOptions richModel + body `shouldSatisfy` T.isInfixOf "## Agent launch" + body `shouldSatisfy` T.isInfixOf "- provider: `claude`" + body `shouldSatisfy` T.isInfixOf "- model: `opus`" + body `shouldSatisfy` T.isInfixOf "- effort: `high`" + body `shouldSatisfy` T.isInfixOf "SEIHOU_AGENT_*" + + it "renders the version probe command and why it exists" $ do + body <- requireBody "blueprints/rich-blueprint" testOptions richModel + body `shouldSatisfy` T.isInfixOf "## Version probe" + body `shouldSatisfy` T.isInfixOf "```bash\ncabal get-version\n```" + body `shouldSatisfy` T.isInfixOf "reads no package-manager format" + + it "renders the blueprint tool allowlist" $ do + body <- requireBody "blueprints/rich-blueprint" testOptions richModel + body `shouldSatisfy` T.isInfixOf "## Tools" + body `shouldSatisfy` T.isInfixOf "- `Bash`" + + it "keeps the whole agent prompt, not just its first paragraph" $ do + body <- requireBody "blueprints/rich-blueprint" testOptions richModel + body `shouldSatisfy` T.isInfixOf "Upgrade the project." + body `shouldSatisfy` T.isInfixOf "```text\nUpgrade the project.\n\nBe careful.\n```" + + it "renders command-derived variables" $ do + body <- requireBody "prompts/rich-prompt" testOptions richModel + body `shouldSatisfy` T.isInfixOf "## Command variables" + body + `shouldSatisfy` T.isInfixOf + "- `head.sha` — runs `git rev-parse HEAD` in `.`, trimmed, capped at 64 bytes — when `IsSet license`" + + it "renders conditional guidance blocks" $ do + body <- requireBody "prompts/rich-prompt" testOptions richModel + body `shouldSatisfy` T.isInfixOf "## Guidance" + body `shouldSatisfy` T.isInfixOf "### Formatting" + body `shouldSatisfy` T.isInfixOf "Run the formatter before finishing." + body `shouldSatisfy` T.isInfixOf "Applies when `Eq license \"MIT\"`." + + describe "registry overview concept" $ do + it "emits one concept describing the registry itself" $ do + (concepts, _) <- renderOrFail testOptions wellFormedModel + sort (Okf.renderConceptId . Okf.conceptIdOf <$> concepts) + `shouldSatisfy` elem "registry/fixture" + + it "links every artifact from the registry concept, grouped by kind" $ do + body <- requireBody "registry/fixture" testOptions wellFormedModel + body `shouldSatisfy` T.isInfixOf "## Modules" + body `shouldSatisfy` T.isInfixOf "](/modules/base.md)" + body `shouldSatisfy` T.isInfixOf "## Recipes" + body `shouldSatisfy` T.isInfixOf "](/recipes/app-recipe.md)" + body `shouldSatisfy` T.isInfixOf "## Blueprints" + body `shouldSatisfy` T.isInfixOf "](/blueprints/app-blueprint.md)" + body `shouldSatisfy` T.isInfixOf "## Prompts" + body `shouldSatisfy` T.isInfixOf "](/prompts/review.md)" + + it "omits a kind section the registry publishes nothing for" $ do + body <- requireBody "registry/fixture" testOptions danglingModel + body `shouldNotSatisfy` T.isInfixOf "## Recipes" + +-- | A fixed producer version, so assertions on the stamped actor do not change +-- every time the package version is bumped. +testOptions :: RenderOptions +testOptions = + RenderOptions + { producerVersion = "9.9.9", + generatedAt = Nothing, + validationProfile = StrictAuthoring, + profileSource = Nothing, + enforceProfile = True + } + +-- | Render a model, failing the example rather than pattern-matching partially. +renderOrFail :: RenderOptions -> DocModel -> IO ([Okf.Concept], [BundleValidationError]) +renderOrFail opts model = + case renderDocBundle opts model of Left errs -> expectationFailure ("Expected render success, got " <> show errs) >> error "unreachable" - Right (concepts, _) -> - case Okf.parseConceptId rawId of - Left err -> expectationFailure ("Bad test concept id: " <> show err) >> error "unreachable" - Right conceptId -> - case filter (\concept -> Okf.conceptIdOf concept == conceptId) concepts of - [concept] -> pure concept - other -> expectationFailure ("Expected one concept, got " <> show (length other)) >> error "unreachable" + Right rendered -> pure rendered +-- | The rendered Markdown body of one concept, which is where every section +-- assertion above looks. +requireBody :: T.Text -> RenderOptions -> DocModel -> IO T.Text +requireBody rawId opts model = Okf.serializeConcept <$> requireConcept rawId opts model + +requireConcept :: T.Text -> RenderOptions -> DocModel -> IO Okf.Concept +requireConcept rawId opts model = do + (concepts, _) <- renderOrFail opts model + case Okf.parseConceptId rawId of + Left err -> expectationFailure ("Bad test concept id: " <> show err) >> error "unreachable" + Right conceptId -> + case filter (\concept -> Okf.conceptIdOf concept == conceptId) concepts of + [concept] -> pure concept + other -> expectationFailure ("Expected one concept, got " <> show (length other)) >> error "unreachable" + isDanglingReference :: BundleValidationError -> Bool isDanglingReference DanglingReference {} = True isDanglingReference _ = False @@ -98,6 +289,55 @@ ] } +-- | Neither the registry entry nor the module says anything about itself, which +-- is what StrictAuthoring would otherwise reject. +undescribedModel :: DocModel +undescribedModel = + DocModel + { repoName = "fixture", + repoDescription = Nothing, + entries = [silentEntry Nothing] + } + +-- | The registry entry is silent but the artifact describes itself. +registrySilentModel :: DocModel +registrySilentModel = + DocModel + { repoName = "fixture", + repoDescription = Nothing, + entries = [silentEntry (Just "the artifact describes itself")] + } + +silentEntry :: Maybe T.Text -> DocEntry +silentEntry artifactDescription = + DocEntry + { name = "base", + kind = DocModuleKind, + version = Nothing, + description = Nothing, + tags = [], + path = "modules/base", + artifact = DocModuleArtifact (silentModuleArtifact artifactDescription), + moduleRefs = [], + entailedRefs = [] + } + +silentModuleArtifact :: Maybe T.Text -> Module +silentModuleArtifact description = + Module + { name = ModuleName "base", + version = Nothing, + description = description, + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + invalidIdModel :: DocModel invalidIdModel = DocModel @@ -118,7 +358,8 @@ tags = ["module"], path = path, artifact = DocModuleArtifact (moduleArtifact name refs), - moduleRefs = refs + moduleRefs = refs, + entailedRefs = [] } moduleArtifact :: T.Text -> [ModuleRef] -> Module @@ -156,7 +397,8 @@ vars = [], prompts = [] }, - moduleRefs = [ModuleRef "base" True, ModuleRef "app" True] + moduleRefs = [ModuleRef "base" True, ModuleRef "app" True], + entailedRefs = [] } blueprintEntry :: DocEntry @@ -185,7 +427,8 @@ launch = Nothing, versionProbe = Nothing }, - moduleRefs = [ModuleRef "base" True] + moduleRefs = [ModuleRef "base" True], + entailedRefs = [] } promptEntry :: DocEntry @@ -213,5 +456,281 @@ launch = Nothing, guidance = [] }, - moduleRefs = [] + moduleRefs = [], + entailedRefs = [] + } + +-- | A registry whose artifacts declare every feature the renderer now covers, +-- including the four -- entailment, launch preferences, a version probe, and +-- command-derived variables -- that no real registry on this machine exercises. +richModel :: DocModel +richModel = + DocModel + { repoName = "fixture", + repoDescription = Just "Fixture", + entries = [richModuleEntry, richRecipeEntry, richBlueprintEntry, otherBlueprintEntry, richPromptEntry] + } + +richModuleEntry :: DocEntry +richModuleEntry = + DocEntry + { name = "rich", + kind = DocModuleKind, + version = Just "0.3.0", + description = Just "A module that declares everything", + tags = ["module"], + path = "modules/rich", + artifact = DocModuleArtifact richModule, + moduleRefs = [], + entailedRefs = [] + } + +richModule :: Module +richModule = + Module + { name = ModuleName "rich", + version = Just "0.3.0", + description = Just "A module that declares everything", + vars = + [ VarDecl + { name = "project.name", + type_ = VTText, + default_ = Nothing, + description = Just "The project name", + required = True, + validation = Just (ValPattern "[a-z]+") + }, + VarDecl + { name = "license", + type_ = VTChoice ["MIT", "BSD-3"], + default_ = Just (VText "MIT"), + description = Nothing, + required = False, + validation = Nothing + }, + VarDecl + { name = "retries", + type_ = VTInt, + default_ = Nothing, + description = Nothing, + required = False, + validation = Just (ValRange 0 5) + } + ], + exports = [VarExport {var = "project.name", alias = Just "app.name"}], + prompts = + [ Prompt + { var = "license", + text = "Which license?", + condition = Just (ExprIsSet "project.name"), + choices = Just ["MIT", "BSD-3"] + } + ], + steps = + [ Step + { strategy = Template, + src = "flake.nix.tpl", + dest = "flake.nix", + condition = Nothing, + patch = Nothing + }, + Step + { strategy = Copy, + src = "gitignore.tpl", + dest = ".gitignore", + condition = Just (ExprEq "license" (VText "MIT")), + patch = Just AppendLineIfAbsent + } + ], + commands = + [ Command + { run = "cabal build", + workDir = Just "app", + condition = Just (ExprIsSet "license") + } + ], + dependencies = [], + removal = + Just + Removal + { steps = + [ RemovalStep {action = RemoveFileAction, dest = "flake.nix", src = Nothing}, + RemovalStep {action = RemoveSectionAction, dest = ".gitignore", src = Nothing} + ], + commands = + [Command {run = "rm -rf dist-newstyle", workDir = Nothing, condition = Nothing}] + }, + migrations = + [ Migration + { from = "0.1.0", + to = "0.2.0", + ops = [MoveFile {src = "old.nix", dest = "new.nix"}] + }, + Migration + { from = "0.2.0", + to = "0.3.0", + ops = + [ DeleteDir {path = "legacy"}, + RunCommand {run = "just fmt", workDir = Just "."} + ] + } + ] + } + +richRecipeEntry :: DocEntry +richRecipeEntry = + DocEntry + { name = "rich-recipe", + kind = DocRecipeKind, + version = Nothing, + description = Just "A recipe that preconfigures its modules", + tags = [], + path = "recipes/rich-recipe", + artifact = + DocRecipeArtifact + Recipe + { name = RecipeName "rich-recipe", + version = Nothing, + description = Just "A recipe that preconfigures its modules", + modules = + [ Dependency + { module_ = ModuleName "rich", + vars = Map.fromList [("project.name", "demo"), ("license", "MIT")] + } + ], + vars = [], + prompts = [] + }, + moduleRefs = [ModuleRef "rich" True], + entailedRefs = [] + } + +richBlueprintEntry :: DocEntry +richBlueprintEntry = + DocEntry + { name = "rich-blueprint", + kind = DocBlueprintKind, + version = Nothing, + description = Just "A blueprint that declares everything", + tags = [], + path = "blueprints/rich-blueprint", + artifact = DocBlueprintArtifact richBlueprint, + moduleRefs = [], + -- One entailed edge resolves inside this registry and one does not, which + -- is the distinction the renderer has to honour. + entailedRefs = + [ EntailedRef {blueprint = "other-blueprint", from = "1.9.0", to = "2.0.0", resolved = True}, + EntailedRef {blueprint = "kiroku", from = "1.9.0", to = "2.0.0", resolved = False} + ] + } + +richBlueprint :: Blueprint +richBlueprint = + Blueprint + { name = ModuleName "rich-blueprint", + version = Nothing, + description = Just "A blueprint that declares everything", + prompt = "Upgrade the project.\n\nBe careful.", + vars = [], + prompts = [], + baseModules = [], + files = [], + allowedTools = Just ["Bash", "Read"], + tags = [], + migrations = + [ BlueprintMigration + { from = "2.4.0", + to = "3.0.0", + prompt = "Cross the breaking change.", + entails = + [ EntailedEdge {blueprint = "other-blueprint", from = "1.9.0", to = "2.0.0"}, + EntailedEdge {blueprint = "kiroku", from = "1.9.0", to = "2.0.0"} + ] + } + ], + launch = + Just + AgentLaunch + { provider = Just "claude", + model = Just "opus", + effort = Just "high", + mode = Nothing + }, + versionProbe = Just "cabal get-version" + } + +-- | The blueprint the rich blueprint entails, so that one entailed edge has a +-- target inside the bundle to link to. +otherBlueprintEntry :: DocEntry +otherBlueprintEntry = + DocEntry + { name = "other-blueprint", + kind = DocBlueprintKind, + version = Nothing, + description = Just "The entailed blueprint", + tags = [], + path = "blueprints/other-blueprint", + artifact = + DocBlueprintArtifact + Blueprint + { name = ModuleName "other-blueprint", + version = Nothing, + description = Just "The entailed blueprint", + prompt = "Do the other thing.", + vars = [], + prompts = [], + baseModules = [], + files = [], + allowedTools = Nothing, + tags = [], + migrations = [], + launch = Nothing, + versionProbe = Nothing + }, + moduleRefs = [], + entailedRefs = [] + } + +richPromptEntry :: DocEntry +richPromptEntry = + DocEntry + { name = "rich-prompt", + kind = DocPromptKind, + version = Nothing, + description = Just "A prompt that declares everything", + tags = [], + path = "prompts/rich-prompt", + artifact = + DocPromptArtifact + AgentPrompt + { name = ModuleName "rich-prompt", + version = Nothing, + description = Just "A prompt that declares everything", + prompt = "Review the change.", + vars = [], + prompts = [], + commandVars = + [ CommandVar + { name = "head.sha", + run = "git rev-parse HEAD", + workDir = Just ".", + condition = Just (ExprIsSet "license"), + trim = True, + maxBytes = Just 64 + } + ], + guidance = + [ PromptGuidance + { title = "Formatting", + body = "Run the formatter before finishing.", + condition = Just (ExprEq "license" (VText "MIT")) + } + ], + files = [], + allowedTools = Nothing, + tags = [], + launch = Nothing + }, + moduleRefs = [], + entailedRefs = [] } diff --git a/test/Seihou/OKF/Extension/DocsSpec.hs b/test/Seihou/OKF/Extension/DocsSpec.hs --- a/test/Seihou/OKF/Extension/DocsSpec.hs +++ b/test/Seihou/OKF/Extension/DocsSpec.hs @@ -1,10 +1,15 @@ module Seihou.OKF.Extension.DocsSpec (tests) where +import Control.Lens ((&), (.~), (?~)) +import Data.Generics.Labels () import Data.Text qualified as T +import Data.Text.IO qualified as TIO import Okf.Bundle qualified as Okf +import Okf.Index qualified as Okf import Okf.Validation qualified as Okf +import Seihou.OKF.Docs.Render (builtinProfileDescriptor) import Seihou.OKF.Extension.Docs -import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.Directory (createDirectoryIfMissing, doesFileExist, doesPathExist) import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec @@ -22,32 +27,114 @@ let registryDir = tmpDir "registry" outDir = tmpDir "out" writeFixtureRegistry registryDir - result <- runDocs DocsOpts {dir = registryDir, out = outDir, force = False} - result `shouldBe` Right ("Wrote 2 concepts to " <> T.pack outDir) + result <- runDocs (docsOpts registryDir outDir False) + result `shouldBe` Right ("Wrote 3 concepts to " <> T.pack outDir) doesFileExist (outDir "modules" "base.md") `shouldReturn` True doesFileExist (outDir "recipes" "base-recipe.md") `shouldReturn` True + doesFileExist (outDir "index.md") `shouldReturn` True + rootIndex <- TIO.readFile (outDir "index.md") + rootIndex `shouldSatisfy` T.isInfixOf "okf_version: \"0.2\"" + doesFileExist (outDir "modules" "index.md") `shouldReturn` True + doesFileExist (outDir "recipes" "index.md") `shouldReturn` True + doesFileExist (outDir "registry" "fixture-registry.md") `shouldReturn` True + doesFileExist (outDir "profile.dhall") `shouldReturn` True + writtenProfile <- TIO.readFile (outDir "profile.dhall") + writtenProfile `shouldBe` builtinProfileDescriptor walked <- Okf.walkBundle outDir case walked of Left err -> expectationFailure ("Expected walkBundle success, got " <> show err) - Right concepts -> Okf.validateBundle Okf.PermissiveConformance concepts `shouldBe` [] + Right concepts -> + Okf.validateBundle + Okf.PermissiveConformance + Okf.VersionUndeclared + (Okf.bundleInventoryOfConcepts concepts) + concepts + `shouldBe` [] it "refuses to overwrite a non-empty output directory without force" $ do withSystemTempDirectory "seihou-okf-docs-force" $ \tmpDir -> do let registryDir = tmpDir "registry" outDir = tmpDir "out" writeFixtureRegistry registryDir - first <- runDocs DocsOpts {dir = registryDir, out = outDir, force = False} - first `shouldBe` Right ("Wrote 2 concepts to " <> T.pack outDir) - second <- runDocs DocsOpts {dir = registryDir, out = outDir, force = False} + first <- runDocs (docsOpts registryDir outDir False) + first `shouldBe` Right ("Wrote 3 concepts to " <> T.pack outDir) + second <- runDocs (docsOpts registryDir outDir False) second `shouldBe` Left ("output directory is not empty: " <> T.pack outDir <> "; pass --force to overwrite") - forced <- runDocs DocsOpts {dir = registryDir, out = outDir, force = True} - forced `shouldBe` Right ("Wrote 2 concepts to " <> T.pack outDir) + forced <- runDocs (docsOpts registryDir outDir True) + forced `shouldBe` Right ("Wrote 3 concepts to " <> T.pack outDir) + it "refuses to write a bundle that violates the house profile" $ do + withSystemTempDirectory "seihou-okf-docs-profile" $ \tmpDir -> do + let registryDir = tmpDir "registry" + outDir = tmpDir "out" + profilePath = tmpDir "demanding.dhall" + writeFixtureRegistry registryDir + TIO.writeFile profilePath demandingProfile + result <- + runDocs (docsOpts registryDir outDir False & #profile ?~ profilePath) + case result of + Right summary -> expectationFailure ("Expected a profile violation, got " <> show summary) + -- Specifically a violation, not an unreadable or uncompilable + -- descriptor, which would also mention the house profile. + Left err -> err `shouldSatisfy` T.isInfixOf "house profile: modules/base: missing required field stale_after" + -- Nothing at all reached disk: the check runs before the output + -- directory is even prepared. + doesPathExist outDir `shouldReturn` False + + it "skips profile enforcement with --no-profile" $ do + withSystemTempDirectory "seihou-okf-docs-no-profile" $ \tmpDir -> do + let registryDir = tmpDir "registry" + outDir = tmpDir "out" + profilePath = tmpDir "demanding.dhall" + writeFixtureRegistry registryDir + TIO.writeFile profilePath demandingProfile + result <- + runDocs + ( docsOpts registryDir outDir False + & #profile ?~ profilePath + & #noProfile .~ True + ) + result `shouldBe` Right ("Wrote 3 concepts to " <> T.pack outDir) + + it "derives its demanding fixture profile from the real descriptor" $ do + demandingProfile `shouldNotBe` builtinProfileDescriptor + it "reports a missing registry file" $ do withSystemTempDirectory "seihou-okf-docs-missing" $ \tmpDir -> do let registryDir = tmpDir "missing" - result <- runDocs DocsOpts {dir = registryDir, out = tmpDir "out", force = False} + result <- runDocs (docsOpts registryDir (tmpDir "out") False) result `shouldBe` Left ("registry file not found: " <> T.pack (registryDir "seihou-registry.dhall")) + +-- | The default option set for a fixture run: strict validation, no generation +-- date, so the written bundle is byte-stable across runs. +docsOpts :: FilePath -> FilePath -> Bool -> DocsOpts +docsOpts registryDir outDir force = + DocsOpts + { dir = registryDir, + out = outDir, + force = force, + generatedAt = Nothing, + permissive = False, + profile = Nothing, + noProfile = False + } + +-- | The house profile, plus one required frontmatter key the generator never +-- emits, so that enforcement has something real to reject. Derived from the +-- real descriptor rather than hand-written, so it stays a valid profile. +-- +-- 'demandingProfileIsDifferent' guards the substitution: if the descriptor is +-- reworded so the anchor no longer matches, that test fails loudly rather than +-- these two silently checking nothing. +demandingProfile :: T.Text +demandingProfile = + T.replace + demandingProfileAnchor + ("[ scalar \"stale_after\" \"A key this generator never emits.\"\n , scalar \"type\"") + builtinProfileDescriptor + +demandingProfileAnchor :: T.Text +demandingProfileAnchor = "[ scalar \"type\"" writeFixtureRegistry :: FilePath -> IO () writeFixtureRegistry registryDir = do