diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,37 @@ ## [Unreleased] +## [0.1.1.0] - 2026-06-28 + +### Added + +- `okf --version`, including git SHA reporting for Cabal and Nix builds when + available. +- Shell completion generation for supported shells. +- `okf help` command with embedded conceptual topic guides (`okf`, `format`, + `validation`, `profiles`), including a guide explaining what the Open Knowledge + Format is. The guides are plain text baked into the binary at compile time, so + `okf help ` works with no network or docs checkout. +- Profile-based validation: `okf validate --profile .dhall` checks a + bundle against a team's house conventions (allowed `type` strings, required + frontmatter keys, `resource:` schemes, file layout, and `# Schema` columns) + declared in a Dhall descriptor. Profiles are not part of the OKF standard, so + deviations are advisory by default; `--profile-enforce` fails the command on + drift. Ships an example bundle (`examples/postgresql-sample`), a sample + descriptor (`docs/profiles/postgresql.dhall`), and a user guide + (`docs/user/profiles.md`). +- Log support: `okf-core` can parse, serialize, and validate `log.md` files; + `okf-cli` can preview, validate, author log entries, and report drift between + bundle logs and git history. +- Canonical OKF profile schema Dhall modules with drift tests. + +### Changed + +- Expanded the README and user guides to cover the current CLI, profile + validation, and log workflows. +- Updated release, Nix, and repository metadata so both packages build and check + as separate Hackage packages. + ## [0.1.0.0] - 2026-06-19 Initial release. diff --git a/okf-cli.cabal b/okf-cli.cabal --- a/okf-cli.cabal +++ b/okf-cli.cabal @@ -1,35 +1,29 @@ -cabal-version: 3.4 -name: okf-cli -version: 0.1.0.0 -synopsis: Command-line interface for Open Knowledge Format bundles +cabal-version: 3.4 +name: okf-cli +version: 0.1.1.0 +synopsis: Command-line interface for Open Knowledge Format bundles description: okf-cli provides the @okf@ executable for working with Open Knowledge Format (OKF) bundles: validating bundles, inspecting their concept graph, and authoring documents from the command line, built on the okf-core library. -category: Data, CLI -license: BSD-3-Clause -license-file: LICENSE -author: Nadeem Bitar -maintainer: nadeem@gmail.com -copyright: (c) 2026 Nadeem Bitar -build-type: Simple +category: Data, CLI +license: BSD-3-Clause +license-file: LICENSE +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: (c) 2026 Nadeem Bitar +build-type: Simple extra-doc-files: CHANGELOG.md common common-options ghc-options: - -Wall - -Wcompat - -Widentities - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wredundant-constraints - -fhide-source-paths - -Wmissing-export-lists - -Wpartial-fields + -Wall -Wcompat -Widentities -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints + -fhide-source-paths -Wmissing-export-lists -Wpartial-fields -Wmissing-deriving-strategies - default-language: GHC2024 + default-language: GHC2024 default-extensions: DeriveAnyClass DuplicateRecordFields @@ -37,42 +31,52 @@ OverloadedStrings library - import: common-options - hs-source-dirs: src + import: common-options + hs-source-dirs: src exposed-modules: Okf.Cli + Okf.Cli.Completions + Okf.Cli.Help + Okf.Cli.Version + other-modules: Paths_okf_cli + autogen-modules: Paths_okf_cli build-depends: - aeson >=2.2 && <2.4, - base >=4.20 && <5, - bytestring >=0.11 && <0.13, - okf-core ^>=0.1.0.0, - generic-lens >=2.2 && <2.4, - lens ^>=5.3, - optparse-applicative >=0.18 && <0.20, - text ^>=2.1, + , aeson >=2.2 && <2.4 + , base >=4.20 && <5 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.8 + , directory >=1.3 && <1.4 + , file-embed >=0.0.15 && <0.1 + , filepath >=1.4 && <1.6 + , generic-lens >=2.2 && <2.4 + , githash ^>=0.1 + , lens ^>=5.3 + , okf-core ^>=0.1.1.0 + , optparse-applicative >=0.18 && <0.20 + , process >=1.6 && <1.7 + , text ^>=2.1 + , time >=1.12 && <1.15 test-suite okf-cli-test - import: common-options - type: exitcode-stdio-1.0 - main-is: Main.hs + import: common-options + type: exitcode-stdio-1.0 + main-is: Main.hs hs-source-dirs: test - build-depends: - base >=4.20 && <5, - okf-cli, - optparse-applicative >=0.18, - text ^>=2.1, + , base >=4.20 && <5 + , directory + , filepath + , okf-cli + , optparse-applicative >=0.18 + , temporary + , text ^>=2.1 executable okf - import: common-options - main-is: Main.hs + import: common-options + main-is: Main.hs hs-source-dirs: app - ghc-options: - -threaded - -rtsopts - -with-rtsopts=-N - + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.20 && <5, - okf-cli, + , base >=4.20 && <5 + , okf-cli diff --git a/src/Okf/Cli.hs b/src/Okf/Cli.hs --- a/src/Okf/Cli.hs +++ b/src/Okf/Cli.hs @@ -3,41 +3,64 @@ ( Command (..), GraphOptions (..), IndexOptions (..), + LogAddOptions (..), + LogOptions (..), + LogSub (..), Options (..), ShowOptions (..), ValidateOptions (..), parserInfo, runCli, runCommand, + runLogAdd, ) where +import Control.Exception (IOException, try) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy.Char8 qualified as LazyByteString import Data.Foldable (traverse_) +import Data.List qualified as List +import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.IO qualified as Text.IO +import Data.Time (defaultTimeLocale, formatTime, getCurrentTime, utctDay) import Okf.Bundle +import Okf.Cli.Completions (CompletionsShell, completionsParser, handleCompletions) +import Okf.Cli.Help (HelpCommand, handleHelpCommand, helpCommandParser) +import Okf.Cli.Version (appVersionWithGit) import Okf.ConceptId import Okf.Document (DocumentParseError (..), body) import Okf.Graph (buildGraph) import Okf.Index +import Okf.Log qualified as Log import Okf.Prelude +import Okf.Profile (ProfileViolation (..), loadProfileFile, validateProfile) import Okf.Validation import Options.Applicative -import System.Exit (exitFailure) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.Exit (ExitCode (..), exitFailure) +import System.FilePath (()) +import System.FilePath qualified as FilePath import System.IO (stderr) +import System.Process (readProcessWithExitCode) data Command = Validate ValidateOptions | Index IndexOptions + | Log LogOptions | GraphCommand GraphOptions | ShowConcept ShowOptions + | Completions CompletionsShell + | Help HelpCommand deriving stock (Show, Eq) data ValidateOptions = ValidateOptions { bundlePath :: !FilePath, - strictMode :: !Bool + strictMode :: !Bool, + profilePath :: !(Maybe FilePath), + profileEnforce :: !Bool, + logEnforce :: !Bool } deriving stock (Show, Eq) @@ -47,6 +70,27 @@ } deriving stock (Show, Eq) +data LogOptions = LogOptions + { bundlePath :: !FilePath, + checkStale :: !Bool, + sinceRef :: !(Maybe Text), + logSub :: !LogSub + } + deriving stock (Show, Eq) + +data LogSub + = LogPreview + | LogAdd LogAddOptions + deriving stock (Show, Eq) + +data LogAddOptions = LogAddOptions + { conceptId :: !(Maybe Text), + kind :: !Text, + message :: !Text, + date :: !(Maybe Text) + } + deriving stock (Show, Eq) + data GraphOptions = GraphOptions { bundlePath :: !FilePath, json :: !Bool @@ -72,12 +116,18 @@ parserInfo :: ParserInfo Options parserInfo = info - (optionsParser <**> helper) + (optionsParser <**> helper <**> versionOption) ( fullDesc <> progDesc "Validate, index, inspect, and graph Open Knowledge Format bundles" <> header "okf - Open Knowledge Format bundle tools" ) +versionOption :: Parser (a -> a) +versionOption = + infoOption + (Text.unpack appVersionWithGit) + (long "version" <> help "Show version information and exit") + optionsParser :: Parser Options optionsParser = Options <$> commandParser @@ -86,8 +136,11 @@ hsubparser ( command "validate" (info (Validate <$> validateOptionsParser <**> helper) (progDesc "Validate an OKF bundle")) <> command "index" (info (Index <$> indexOptionsParser <**> helper) (progDesc "Preview or write generated index.md files")) + <> command "log" (info (Log <$> logOptionsParser <**> helper) (progDesc "Preview and check log.md files")) <> command "graph" (info (GraphCommand <$> graphOptionsParser <**> helper) (progDesc "Print a bundle graph")) <> command "show" (info (ShowConcept <$> showOptionsParser <**> helper) (progDesc "Show one concept")) + <> command "completions" (info (Completions <$> completionsParser <**> helper) (progDesc "Generate a shell completion script (bash, zsh, fish)")) + <> command "help" (info (Help <$> helpCommandParser <**> helper) (progDesc "Show conceptual help topics")) ) validateOptionsParser :: Parser ValidateOptions @@ -95,6 +148,15 @@ ValidateOptions <$> bundleArgument <*> switch (long "strict" <> help "Require recommended authoring fields") + <*> optional + ( strOption + ( long "profile" + <> metavar "PROFILE" + <> help "Path to a Dhall profile descriptor to check (advisory)" + ) + ) + <*> switch (long "profile-enforce" <> help "Exit non-zero when profile checks find deviations") + <*> switch (long "log-enforce" <> help "Exit non-zero when log staleness advisories are found") indexOptionsParser :: Parser IndexOptions indexOptionsParser = @@ -102,6 +164,75 @@ <$> bundleArgument <*> switch (long "write" <> help "Write generated index.md files instead of previewing") +logOptionsParser :: Parser LogOptions +logOptionsParser = + logAddCommandParser <|> logPreviewOptionsParser + +logPreviewOptionsParser :: Parser LogOptions +logPreviewOptionsParser = + LogOptions + <$> bundleArgument + <*> switch (long "check-stale" <> help "Report concepts newer than their nearest log.md") + <*> optional + ( Text.pack + <$> strOption + ( long "since" + <> metavar "GIT_REF" + <> help "Report git drift since a ref (implemented in Milestone 6)" + ) + ) + <*> pure LogPreview + +logAddCommandParser :: Parser LogOptions +logAddCommandParser = + hsubparser + ( command + "add" + ( info + (logAddOptionsToCommand <$> bundleArgument <*> logAddOptionsParser <**> helper) + (progDesc "Append an entry to the nearest log.md") + ) + ) + +logAddOptionsToCommand :: FilePath -> LogAddOptions -> LogOptions +logAddOptionsToCommand path addOptions = + LogOptions + { bundlePath = path, + checkStale = False, + sinceRef = Nothing, + logSub = LogAdd addOptions + } + +logAddOptionsParser :: Parser LogAddOptions +logAddOptionsParser = + LogAddOptions + <$> optional (Text.pack <$> strArgument (metavar "CONCEPT_ID" <> help "Concept ID whose directory log.md should be updated")) + <*> ( Text.pack + <$> strOption + ( long "kind" + <> metavar "KIND" + <> value "Update" + <> showDefault + <> help "Leading bold log entry kind" + ) + ) + <*> ( Text.pack + <$> strOption + ( short 'm' + <> long "message" + <> metavar "MESSAGE" + <> help "Log entry message" + ) + ) + <*> optional + ( Text.pack + <$> strOption + ( long "date" + <> metavar "YYYY-MM-DD" + <> help "Entry date; defaults to today in UTC" + ) + ) + graphOptionsParser :: Parser GraphOptions graphOptionsParser = GraphOptions @@ -122,19 +253,54 @@ runCommand = \case Validate options -> runValidate options Index options -> runIndex options + Log options -> runLog options GraphCommand options -> runGraph options ShowConcept options -> runShow options + Completions shell -> handleCompletions shell + Help helpCommand -> handleHelpCommand helpCommand runValidate :: ValidateOptions -> IO () -runValidate ValidateOptions {bundlePath, strictMode} = do +runValidate ValidateOptions {bundlePath, strictMode, profilePath, profileEnforce, logEnforce} = do concepts <- loadBundleOrExit bundlePath - let profile = if strictMode then StrictAuthoring else PermissiveConformance - case validateBundle profile concepts of - [] -> Text.IO.putStrLn ("OK: " <> Text.pack (show (length concepts)) <> " concepts") - errors -> do - mapM_ (Text.IO.hPutStrLn stderr . renderBundleValidationError) errors - exitFailure + logs <- loadLogsOrExit bundlePath + let coreProfile = if strictMode then StrictAuthoring else PermissiveConformance + coreErrors = validateBundle coreProfile concepts <> validateBundleLogs logs + mapM_ (Text.IO.hPutStrLn stderr . renderBundleValidationError) coreErrors + let staleness = logStaleness concepts logs + mapM_ (Text.IO.hPutStrLn stderr . ("log: " <>) . renderLogStaleness) staleness + + profileViolations <- case profilePath of + Nothing -> pure [] + Just path -> do + loaded <- loadProfileFile path + case loaded of + Left err -> dieText ("Failed to load profile " <> Text.pack path <> ": " <> err) + Right spec -> do + let violations = validateProfile spec concepts + mapM_ (Text.IO.hPutStrLn stderr . ("profile: " <>) . renderProfileViolation) violations + pure violations + + let coreFailed = any bundleValidationErrorIsFailure coreErrors + profileFailed = profileEnforce && not (null profileViolations) + logFailed = logEnforce && (any bundleValidationErrorIsAdvisory coreErrors || not (null staleness)) + if coreFailed || profileFailed || logFailed + then exitFailure + else do + Text.IO.putStrLn ("OK: " <> Text.pack (show (length concepts)) <> " concepts") + unless (null profileViolations) $ + Text.IO.putStrLn + ( "profile: " + <> Text.pack (show (length profileViolations)) + <> " advisory deviation(s) (use --profile-enforce to fail)" + ) + unless (null staleness) $ + Text.IO.putStrLn + ( "log: " + <> Text.pack (show (length staleness)) + <> " stale concept advisory/advisories (use --log-enforce to fail)" + ) + runIndex :: IndexOptions -> IO () runIndex IndexOptions {bundlePath, write} = if write @@ -147,6 +313,133 @@ indexes <- loadIndexesOrExit bundlePath mapM_ renderIndexPreview indexes +runLog :: LogOptions -> IO () +runLog LogOptions {bundlePath, checkStale, sinceRef, logSub = LogPreview} = do + logs <- loadLogsOrExit bundlePath + mapM_ renderLogPreview logs + let logErrors = validateBundleLogs logs + mapM_ (Text.IO.hPutStrLn stderr . renderBundleValidationError) logErrors + case sinceRef of + Nothing -> pure () + Just ref -> runGitDriftCheck bundlePath ref logs + staleness <- + if checkStale + then do + concepts <- loadBundleOrExit bundlePath + pure (logStaleness concepts logs) + else pure [] + mapM_ (Text.IO.hPutStrLn stderr . ("log: " <>) . renderLogStaleness) staleness + when (any bundleValidationErrorIsFailure logErrors) exitFailure +runLog LogOptions {bundlePath, logSub = LogAdd addOptions} = + runLogAdd bundlePath addOptions + +runLogAdd :: FilePath -> LogAddOptions -> IO () +runLogAdd bundlePath LogAddOptions {conceptId, kind, message, date} = do + entryDate <- maybe todayDate pure date + targetPath <- resolveLogTarget bundlePath conceptId + let absolutePath = bundlePath targetPath + entry = Log.LogEntry {Log.logKind = Just kind, Log.logText = message} + exists <- doesFileExist absolutePath + existingLog <- + if exists + then Log.parseLog <$> Text.IO.readFile absolutePath + else pure (emptyLogFor targetPath) + createDirectoryIfMissing True (FilePath.takeDirectory absolutePath) + Text.IO.writeFile absolutePath (Log.serializeLog (Log.appendLogEntry entryDate entry existingLog)) + Text.IO.putStrLn ("Wrote " <> Text.pack targetPath <> " for " <> entryDate) + +resolveLogTarget :: FilePath -> Maybe Text -> IO FilePath +resolveLogTarget _ Nothing = + pure "log.md" +resolveLogTarget bundlePath (Just rawConceptId) = do + parsed <- either (dieText . renderConceptIdError rawConceptId) pure (parseConceptId rawConceptId) + concepts <- loadBundleOrExit bundlePath + when (isNothing (findConcept parsed concepts)) $ + Text.IO.hPutStrLn stderr ("log: warning: concept not found: " <> rawConceptId) + pure (logPathForConcept parsed) + +logPathForConcept :: ConceptId -> FilePath +logPathForConcept conceptId = + case FilePath.takeDirectory (conceptIdToFilePath conceptId) of + "." -> "log.md" + directory -> directory "log.md" + +emptyLogFor :: FilePath -> Log.Log +emptyLogFor targetPath = + Log.Log + { Log.logTitle = defaultLogTitle targetPath, + Log.logDays = [] + } + +defaultLogTitle :: FilePath -> Text +defaultLogTitle targetPath = + case FilePath.takeDirectory targetPath of + "." -> "Bundle Update Log" + directory -> Text.pack directory <> " Update Log" + +todayDate :: IO Text +todayDate = + Text.pack . formatTime defaultTimeLocale "%Y-%m-%d" . utctDay <$> getCurrentTime + +runGitDriftCheck :: FilePath -> Text -> [LogFile] -> IO () +runGitDriftCheck bundlePath ref logs = do + result <- + try + ( readProcessWithExitCode + "git" + ["-C", bundlePath, "diff", "--name-only", "--relative", Text.unpack ref, "--", "."] + "" + ) + case result of + Left (exception :: IOException) -> + Text.IO.hPutStrLn stderr ("log: skipped git drift check: " <> Text.pack (show exception)) + Right (exitCode, output, errOutput) -> + case exitCode of + ExitSuccess -> + mapM_ (Text.IO.hPutStrLn stderr . ("git: " <>) . renderGitDrift) (gitDriftForChangedPaths logs (Text.lines (Text.pack output))) + ExitFailure _ -> + Text.IO.hPutStrLn stderr ("log: skipped git drift check: " <> firstNonEmpty (Text.pack errOutput) (Text.pack output)) + +data GitDrift = GitDrift + { driftConceptPath :: !FilePath, + driftLogPath :: !(Maybe FilePath) + } + deriving stock (Generic, Eq, Show) + +gitDriftForChangedPaths :: [LogFile] -> [Text] -> [GitDrift] +gitDriftForChangedPaths logs changed = + [ GitDrift conceptPath nearestLog + | conceptPath <- changedConcepts, + let nearestLog = nearestEnclosingLogPath conceptPath allLogPaths, + maybe True (`Set.notMember` changedSet) nearestLog + ] + where + changedPaths = Text.unpack <$> filter (not . Text.null) changed + changedSet = Set.fromList changedPaths + changedConcepts = + [ path + | path <- changedPaths, + FilePath.takeExtension path == ".md", + not (isReservedMarkdownFile path) + ] + changedLogs = + [ path + | path <- changedPaths, + FilePath.takeFileName path == "log.md" + ] + allLogPaths = List.nub (changedLogs <> (logSourcePath <$> logs)) + +renderGitDrift :: GitDrift -> Text +renderGitDrift GitDrift {driftConceptPath, driftLogPath} = + Text.pack driftConceptPath + <> " changed without " + <> maybe "an enclosing log.md" (Text.pack . (<> " changing")) driftLogPath + +firstNonEmpty :: Text -> Text -> Text +firstNonEmpty primary fallback + | Text.null (Text.strip primary) = Text.strip fallback + | otherwise = Text.strip primary + runGraph :: GraphOptions -> IO () runGraph GraphOptions {bundlePath} = do concepts <- loadBundleOrExit bundlePath @@ -174,6 +467,13 @@ Left bundleError -> dieText (renderBundleError bundleError) Right indexes -> pure indexes +loadLogsOrExit :: FilePath -> IO [LogFile] +loadLogsOrExit bundlePath = do + result <- walkLogs bundlePath + case result of + Left bundleError -> dieText (renderBundleError bundleError) + Right logs -> pure logs + renderBundleValidationError :: BundleValidationError -> Text renderBundleValidationError = \case DocumentInvalid conceptId error_ -> @@ -182,7 +482,42 @@ renderConceptId source <> ": link to missing concept: " <> renderConceptId target DuplicateConceptId conceptId -> "duplicate concept ID: " <> renderConceptId conceptId + LogInvalid path error_ -> + Text.pack path <> ": " <> renderLogValidationError error_ +bundleValidationErrorIsFailure :: BundleValidationError -> Bool +bundleValidationErrorIsFailure = \case + LogInvalid _ error_ -> Log.logErrorIsStructural error_ + _ -> True + +bundleValidationErrorIsAdvisory :: BundleValidationError -> Bool +bundleValidationErrorIsAdvisory = not . bundleValidationErrorIsFailure + +renderProfileViolation :: ProfileViolation -> Text +renderProfileViolation = \case + TypeNotInProfile cid ctype -> + renderConceptId cid <> ": type not in profile vocabulary: " <> ctype + MissingProfileField cid key -> + renderConceptId cid <> ": missing profile-required field: " <> key + PathPatternMismatch cid ctype patternText -> + renderConceptId cid <> ": " <> ctype <> " must match path pattern: " <> patternText + MissingResource cid ctype scheme -> + renderConceptId cid <> ": " <> ctype <> " requires a resource with scheme " <> scheme <> "://" + ResourceSchemeMismatch cid scheme resourceValue -> + renderConceptId cid <> ": resource must use scheme " <> scheme <> "://, found: " <> resourceValue + MissingSchemaSection cid ctype -> + renderConceptId cid <> ": " <> ctype <> " requires a # Schema section" + SchemaColumnsMismatch cid ctype expected actual -> + renderConceptId cid + <> ": " + <> ctype + <> " # Schema columns " + <> renderList actual + <> " do not start with required " + <> renderList expected + where + renderList xs = "[" <> Text.intercalate ", " xs <> "]" + renderValidationErrorText :: ValidationError -> Text renderValidationErrorText = \case MissingRequiredField fieldName -> "missing required field: " <> fieldName @@ -190,10 +525,31 @@ MissingRecommendedField fieldName -> "missing recommended field: " <> fieldName FieldMustBeListOfText fieldName -> "field must be a list of text values: " <> fieldName +renderLogValidationError :: Log.LogValidationError -> Text +renderLogValidationError = \case + Log.LogDateNotIso dateText -> "log date heading is not YYYY-MM-DD: " <> dateText + Log.LogDaysOutOfOrder earlier later -> "log dates are not newest first: " <> earlier <> " before " <> later + Log.LogEmptyDay dateText -> "log date group has no entries: " <> dateText + +renderLogStaleness :: LogStaleness -> Text +renderLogStaleness LogStaleness {staleConcept, staleConceptDate, staleLogPath, staleLogDate} = + renderConceptId staleConcept + <> ": timestamp date " + <> staleConceptDate + <> case (staleLogPath, staleLogDate) of + (Nothing, Nothing) -> " has no enclosing log.md" + (Just path, Nothing) -> " is newer than empty log " <> Text.pack path + (Just path, Just logDate) -> " is newer than " <> Text.pack path <> " newest entry " <> logDate + (Nothing, Just logDate) -> " is newer than missing log date " <> logDate + renderIndexPreview :: (FilePath, Text) -> IO () renderIndexPreview (path, content) = do Text.IO.putStrLn ("--- " <> Text.pack path) Text.IO.putStr content + +renderLogPreview :: LogFile -> IO () +renderLogPreview logFile = + renderIndexPreview (logSourcePath logFile, Log.serializeLog (logContent logFile)) renderConcept :: Concept -> IO () renderConcept concept = do diff --git a/src/Okf/Cli/Completions.hs b/src/Okf/Cli/Completions.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Cli/Completions.hs @@ -0,0 +1,148 @@ +-- | Shell completion script generation for the @okf@ CLI. +-- +-- The generated scripts do not hard-code okf's command list. Instead they call +-- the @okf@ binary back at completion time using optparse-applicative's built-in +-- completion protocol (@--bash-completion-index@, @--bash-completion-word@, and +-- @--bash-completion-enriched@). Because the binary walks its own parser tree to +-- answer, every subcommand and flag is completed automatically and the scripts +-- never need to change when the parser grows. +-- +-- Bash uses the plain protocol (one word per line); Zsh and Fish use the enriched +-- protocol (@worddescription@) so each candidate shows its @progDesc@ text. +module Okf.Cli.Completions + ( CompletionsShell (..), + completionsParser, + handleCompletions, + renderCompletionScript, + ) +where + +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import Options.Applicative + +-- | The shells for which okf can emit a completion script. +data CompletionsShell + = Bash + | Zsh + | Fish + deriving stock (Show, Eq) + +-- | Parse the @completions @ subcommand: a single required positional +-- argument naming the shell. +completionsParser :: Parser CompletionsShell +completionsParser = + argument + (maybeReader readShell) + ( metavar "SHELL" + <> help "Shell to generate a completion script for: bash, zsh, or fish" + ) + where + readShell = \case + "bash" -> Just Bash + "zsh" -> Just Zsh + "fish" -> Just Fish + _ -> Nothing + +-- | Print the requested shell's completion script to standard output. +handleCompletions :: CompletionsShell -> IO () +handleCompletions = Text.IO.putStr . renderCompletionScript + +-- | The static completion script for a shell. Each is a pure 'Text' constant; +-- all completion logic is delegated to the @okf@ binary at runtime. +renderCompletionScript :: CompletionsShell -> Text +renderCompletionScript = \case + Bash -> bashScript + Zsh -> zshScript + Fish -> fishScript + +-- | Bash completion script. Bash has no native description display, so this uses +-- the plain protocol (@--bash-completion-index@ only). +bashScript :: Text +bashScript = + Text.unlines + [ "_okf_completions() {", + " local CMDLINE", + " local IFS=$'\\n'", + " CMDLINE=(--bash-completion-index $COMP_CWORD)", + "", + " for arg in ${COMP_WORDS[@]}; do", + " CMDLINE=(${CMDLINE[@]} --bash-completion-word \"$arg\")", + " done", + "", + " COMPREPLY=( $(okf \"${CMDLINE[@]}\" 2>/dev/null) )", + "}", + "", + "complete -o filenames -F _okf_completions okf" + ] + +-- | Zsh completion script. Uses the enriched protocol and @_describe@ to show +-- descriptions alongside candidates. +zshScript :: Text +zshScript = + Text.unlines + [ "#compdef okf", + "", + "_okf() {", + " local -a completions", + " local CMDLINE", + " local IFS=$'\\n'", + "", + " CMDLINE=(--bash-completion-enriched --bash-completion-index $((CURRENT - 1)))", + "", + " for arg in ${words[@]}; do", + " CMDLINE=(${CMDLINE[@]} --bash-completion-word \"$arg\")", + " done", + "", + " local line", + " for line in $(okf \"${CMDLINE[@]}\" 2>/dev/null); do", + " local word=${line%%$'\\t'*}", + " local desc=${line#*$'\\t'}", + " if [[ \"$word\" != \"$desc\" ]]; then", + " completions+=(\"${word//:/\\\\:}:${desc}\")", + " else", + " completions+=(\"$word\")", + " fi", + " done", + "", + " if [[ ${#completions[@]} -gt 0 ]]; then", + " _describe 'okf' completions", + " fi", + "}", + "", + "_okf" + ] + +-- | Fish completion script. Uses the enriched protocol and Fish's native +-- @worddescription@ completion format. +fishScript :: Text +fishScript = + Text.unlines + [ "# Disable file completion by default", + "complete -c okf -f", + "", + "function __okf_complete", + " set -l tokens (commandline -cop)", + " set -l current (commandline -ct)", + " set -l index (count $tokens)", + "", + " set -l args --bash-completion-enriched --bash-completion-index $index", + " for token in $tokens", + " set args $args --bash-completion-word $token", + " end", + " set args $args --bash-completion-word \"$current\"", + "", + " for line in (okf $args 2>/dev/null)", + " # Split on tab: worddescription", + " set -l parts (string split \\t -- $line)", + " if test (count $parts) -ge 2", + " printf '%s\\t%s\\n' $parts[1] $parts[2]", + " else", + " echo $line", + " end", + " end", + "end", + "", + "complete -c okf -a '(__okf_complete)'" + ] diff --git a/src/Okf/Cli/Help.hs b/src/Okf/Cli/Help.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Cli/Help.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Conceptual @help@ topic guides for the @okf@ CLI. +-- +-- Each topic's content lives in a standalone plain-text file under +-- @okf-cli/help/@ and is embedded into the binary at compile time with +-- @file-embed@'s 'embedStringFile' splice. The shipped @okf@ executable is +-- therefore self-contained: @okf help okf@ works with no extra files on disk +-- and no network access. +-- +-- Topic files are written as terminal-oriented plain text (ALL-CAPS section +-- headers, 2-space indented bodies) and printed verbatim; there is no Markdown +-- rendering step. +module Okf.Cli.Help + ( HelpCommand (..), + HelpTopic (..), + helpTopics, + helpCommandParser, + handleHelpCommand, + ) +where + +import Data.FileEmbed (embedStringFile) +import Data.Foldable (find, forM_) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import Options.Applicative + +-- | A bare @help@ lists topics; @help @ shows one. +data HelpCommand + = ListTopics + | ShowTopic !Text + deriving stock (Show, Eq) + +-- | A single help guide: short name, one-line description, embedded content. +data HelpTopic = HelpTopic + { topicName :: !Text, + topicDescription :: !Text, + topicContent :: !Text + } + deriving stock (Show, Eq) + +-- | All available help topics, in display order. +helpTopics :: [HelpTopic] +helpTopics = + [ HelpTopic "okf" "What the Open Knowledge Format is" okfTopicContent, + HelpTopic "format" "Bundle layout, concept IDs, frontmatter, and links" formatTopicContent, + HelpTopic "validation" "How bundles are validated and referential integrity" validationTopicContent, + HelpTopic "profiles" "Checking a bundle against house conventions" profilesTopicContent + ] + +okfTopicContent :: Text +okfTopicContent = $(embedStringFile "help/okf.md") + +formatTopicContent :: Text +formatTopicContent = $(embedStringFile "help/format.md") + +validationTopicContent :: Text +validationTopicContent = $(embedStringFile "help/validation.md") + +profilesTopicContent :: Text +profilesTopicContent = $(embedStringFile "help/profiles.md") + +-- | Parse @help [TOPIC]@. With no argument, 'pure ListTopics' wins via '<|>'. +helpCommandParser :: Parser HelpCommand +helpCommandParser = + showTopicParser <|> pure ListTopics + where + showTopicParser = + ShowTopic . Text.pack + <$> strArgument + ( metavar "TOPIC" + <> help ("Help topic: " <> Text.unpack topicList) + ) + topicList = Text.intercalate ", " (map topicName helpTopics) + +-- | Run the @help@ command: list the topic index or print one topic. +handleHelpCommand :: HelpCommand -> IO () +handleHelpCommand = \case + ListTopics -> listTopics + ShowTopic name -> showTopic name + +listTopics :: IO () +listTopics = do + Text.IO.putStrLn "HELP TOPICS\n" + forM_ helpTopics $ \t -> + Text.IO.putStrLn (" " <> padRight 12 (topicName t) <> topicDescription t) + Text.IO.putStrLn "\nUse 'okf help ' for details." + where + padRight n t = t <> Text.replicate (max 0 (n - Text.length t)) " " + +showTopic :: Text -> IO () +showTopic name = + case find (\t -> topicName t == Text.toLower name) helpTopics of + Just t -> Text.IO.putStrLn (topicContent t) + Nothing -> do + Text.IO.putStrLn ("Unknown topic: " <> name) + Text.IO.putStrLn ("Available: " <> Text.intercalate ", " (map topicName helpTopics)) diff --git a/src/Okf/Cli/Version.hs b/src/Okf/Cli/Version.hs new file mode 100644 --- /dev/null +++ b/src/Okf/Cli/Version.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Version reporting for the @okf@ CLI. +-- +-- The short git commit hash is resolved at build time from one of two sources: +-- +-- * @cabal build@: the @.git/@ directory is present, so the Template Haskell +-- splice 'tGitInfoCwdTry' reads it directly. +-- * @nix build@: @.git/@ is stripped, so the hash is injected by the Nix +-- expression as the CPP macro @GIT_HASH@ (see @nix/haskell.nix@). +-- +-- If neither source is available (e.g. a source tarball), the hash is omitted. +module Okf.Cli.Version + ( appVersion, + appVersionWithGit, + gitCommitShort, + ) +where + +import Data.Text (Text, pack) +import Data.Version (showVersion) +import GitHash (GitInfo, giHash, tGitInfoCwdTry) +import Paths_okf_cli (version) + +-- | Base package version from @okf-cli.cabal@, e.g. @"0.1.0.0"@. +appVersion :: Text +appVersion = pack (showVersion version) + +-- | Git info read at compile time from @.git/@ in the current working directory. +-- 'Right' when building inside a git checkout, 'Left' with a message otherwise. +gitInfo :: Either String GitInfo +gitInfo = $$tGitInfoCwdTry + +-- | Fallback hash injected by Nix via @-DGIT_HASH="..."@ when @.git/@ is absent. +nixGitHash :: Maybe Text +#ifdef GIT_HASH +nixGitHash = Just GIT_HASH +#else +nixGitHash = Nothing +#endif + +-- | Short git commit hash (first 7 characters). Prefers the compile-time @.git/@ +-- read, then the Nix-injected macro, then 'Nothing'. +gitCommitShort :: Maybe Text +gitCommitShort = case gitInfo of + Right gi -> Just (pack (take 7 (giHash gi))) + Left _ -> nixGitHash + +-- | Full version string, e.g. @"okf v0.1.0.0 (a1b2c3d)"@, or @"okf v0.1.0.0"@ when +-- no commit hash is available. +appVersionWithGit :: Text +appVersionWithGit = "okf v" <> appVersion <> commitSuffix + where + commitSuffix = maybe "" (\c -> " (" <> c <> ")") gitCommitShort diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,20 +1,92 @@ module Main (main) where import Control.Monad (unless) +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import Okf.Cli +import Okf.Cli.Help (HelpTopic (..), helpTopics) import Options.Applicative +import System.Directory (createDirectoryIfMissing, getTemporaryDirectory, removeDirectoryRecursive) import System.Exit (exitFailure) - -import Okf.Cli +import System.FilePath (()) +import System.IO.Temp (createTempDirectory) main :: IO () main = do + logAddWrites <- testLogAddWritesFile let results = - [ parseSucceeds ["validate", "bundle"] - , parseSucceeds ["validate", "bundle", "--strict"] - , parseSucceeds ["index", "bundle", "--write"] - , parseSucceeds ["graph", "bundle", "--json"] - , parseSucceeds ["show", "bundle", "tables/orders"] - , parseFails ["hello"] + [ parseSucceeds ["validate", "bundle"], + parseSucceeds ["validate", "bundle", "--strict"], + parseSucceeds ["validate", "bundle", "--profile", "p.dhall"], + parseSucceeds ["validate", "bundle", "--profile", "p.dhall", "--profile-enforce"], + parseSucceeds ["validate", "bundle", "--log-enforce"], + parseValidateMatches + ["validate", "b", "--profile", "p.dhall", "--profile-enforce"] + ValidateOptions + { bundlePath = "b", + strictMode = False, + profilePath = Just "p.dhall", + profileEnforce = True, + logEnforce = False + }, + parseValidateMatches + ["validate", "b"] + ValidateOptions + { bundlePath = "b", + strictMode = False, + profilePath = Nothing, + profileEnforce = False, + logEnforce = False + }, + parseValidateMatches + ["validate", "b", "--log-enforce"] + ValidateOptions + { bundlePath = "b", + strictMode = False, + profilePath = Nothing, + profileEnforce = False, + logEnforce = True + }, + parseSucceeds ["index", "bundle", "--write"], + parseSucceeds ["log", "bundle"], + parseSucceeds ["log", "bundle", "--check-stale"], + parseLogMatches + ["log", "b", "--check-stale", "--since", "HEAD~1"] + LogOptions + { bundlePath = "b", + checkStale = True, + sinceRef = Just "HEAD~1", + logSub = LogPreview + }, + parseLogMatches + ["log", "add", "b", "tables/users", "--kind", "Update", "-m", "Refreshed schema", "--date", "2026-06-23"] + LogOptions + { bundlePath = "b", + checkStale = False, + sinceRef = Nothing, + logSub = + LogAdd + LogAddOptions + { conceptId = Just "tables/users", + kind = "Update", + message = "Refreshed schema", + date = Just "2026-06-23" + } + }, + parseSucceeds ["graph", "bundle", "--json"], + parseSucceeds ["show", "bundle", "tables/orders"], + parseSucceeds ["completions", "bash"], + parseSucceeds ["completions", "zsh"], + parseSucceeds ["completions", "fish"], + parseFails ["completions", "elvish"], + parseSucceeds ["help"], + parseSucceeds ["help", "okf"], + parseSucceeds ["help", "format"], + any ((== "okf") . topicName) helpTopics, + all (not . Text.null . topicContent) helpTopics, + parseShowsInfo ["--version"], + parseFails ["hello"], + logAddWrites ] unless (and results) exitFailure @@ -24,8 +96,72 @@ Success _ -> True _ -> False +-- | Parse a @validate@ invocation and check it yields exactly the expected +-- 'ValidateOptions' (so the new @--profile@/@--profile-enforce@ flags map to the +-- right fields). +parseValidateMatches :: [String] -> ValidateOptions -> Bool +parseValidateMatches args expected = + case execParserPure defaultPrefs parserInfo args of + Success (Options (Validate opts)) -> opts == expected + _ -> False + +parseLogMatches :: [String] -> LogOptions -> Bool +parseLogMatches args expected = + case execParserPure defaultPrefs parserInfo args of + Success (Options (Log opts)) -> opts == expected + _ -> False + +testLogAddWritesFile :: IO Bool +testLogAddWritesFile = do + temporaryDirectory <- getTemporaryDirectory + root <- createTempDirectory temporaryDirectory "okf-cli-log-add" + createDirectoryIfMissing True (root "tables") + Text.IO.writeFile + (root "tables" "users.md") + ( Text.unlines + [ "---", + "type: Table", + "timestamp: 2026-06-23T10:00:00Z", + "---", + "", + "# Users" + ] + ) + runCommand + ( Log + LogOptions + { bundlePath = root, + checkStale = False, + sinceRef = Nothing, + logSub = + LogAdd + LogAddOptions + { conceptId = Just "tables/users", + kind = "Update", + message = "Refreshed schema", + date = Just "2026-06-23" + } + } + ) + written <- Text.IO.readFile (root "tables" "log.md") + removeDirectoryRecursive root + pure + ( "## 2026-06-23" `Text.isInfixOf` written + && "* **Update**: Refreshed schema" `Text.isInfixOf` written + ) + parseFails :: [String] -> Bool parseFails args = + case execParserPure defaultPrefs parserInfo args of + Failure _ -> True + CompletionInvoked _ -> True + Success _ -> False + +-- | An info flag such as @--version@ or @--help@ short-circuits parsing: it is +-- recognized (not an unknown-argument error) and reported as a 'Failure' that +-- carries the text to print and a success exit code. +parseShowsInfo :: [String] -> Bool +parseShowsInfo args = case execParserPure defaultPrefs parserInfo args of Failure _ -> True CompletionInvoked _ -> True