diff --git a/gachi-retrofit.cabal b/gachi-retrofit.cabal new file mode 100644 --- /dev/null +++ b/gachi-retrofit.cabal @@ -0,0 +1,78 @@ +cabal-version: 3.0 +name: gachi-retrofit +version: 0.1.0.0 +synopsis: Non-destructive codebase retrofitting engine and diagnostic repository inspector for Gachi +description: + Static analysis of arbitrary target checkouts: detects language stacks, build systems, + existing tests, documentation gaps relative to DOC_STRATEGY.md, Git hook attribution + conformance, and physical verification readiness ('gachi retrofit'). +license: EUPL-1.2 +author: Nadia Yvette Chambers +maintainer: nadia.yvette.chambers@ik.me +category: Development, Tools +build-type: Simple +tested-with: + GHC == 9.10.3, + GHC == 9.12.4, + GHC == 9.14.1 + +library + exposed-modules: + Gachi.Retrofit + Gachi.Retrofit.Diagnostic + Gachi.Retrofit.Overlay + Gachi.Retrofit.QualityGate + Gachi.Retrofit.Report + Gachi.Retrofit.Types + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: + OverloadedStrings + DerivingStrategies + ScopedTypeVariables + ghc-options: + -Wall + -Wcompat + -Wredundant-constraints + build-depends: + base >= 4.14 && < 5, + bytestring >= 0.10, + text >= 2.0, + containers >= 0.6, + directory >= 1.3, + filepath >= 1.4, + process >= 1.6, + gachi-core >= 0.1, + gachi-schema >= 0.1, + gachi-scaffold >= 0.1, + gachi-sync >= 0.1 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: Haskell2010 + default-extensions: + OverloadedStrings + DerivingStrategies + ScopedTypeVariables + ghc-options: + -Wall + -Wcompat + -Wredundant-constraints + -threaded + build-depends: + base >= 4.14 && < 5, + gachi-retrofit, + gachi-core, + gachi-schema, + gachi-scaffold, + gachi-sync, + bytestring >= 0.10, + text >= 2.0, + containers >= 0.6, + directory >= 1.3, + filepath >= 1.4, + process >= 1.6, + time >= 1.9, + hspec >= 2.10 diff --git a/src/Gachi/Retrofit.hs b/src/Gachi/Retrofit.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Retrofit.hs @@ -0,0 +1,210 @@ +-- | Module: Gachi.Retrofit +-- Description: Non-destructive codebase retrofitting engine & diagnostic inspector +-- +-- This is the root library module for @gachi-retrofit@. It provides the unified +-- public API for inspecting legacy, single-package, or foreign repositories, evaluating +-- six diagnostic dimensions, and computing actionable remediation plans per +-- Phase 4 and Milestone 4.1. +-- +-- = Monograph: The Theory of Non-Destructive Codebase Retrofitting +-- +-- == 1. The Retrofitting Problem and the Conservation of Domain Logic +-- +-- Software ecosystems face a perennial tension between standardization and legacy codebases. +-- High-assurance development environments require strict invariants: zero-warning builds under +-- @-Wall -Wcompat -Wredundant-constraints@, clean linters (zero HLint hints), bi-directional +-- Tagref cross-references, unbroken documentation hyperlinks, and measured in-code comment +-- density. However, existing repositories—whether single-package libraries, ad-hoc research +-- prototypes, or foreign language checkouts—rarely conform to these contracts initially. +-- +-- Traditional migration approaches either: +-- 1. Demand exhaustive manual refactoring, creating high friction and human error. +-- 2. Force destructive scaffolding re-generation, risking clobbering, overwriting, or deleting +-- irreplaceable domain logic. +-- +-- The Gachi Retrofitting Engine establishes an alternative: __Non-Destructive Codebase Retrofitting__. +-- Let \(\mathcal{P}\) denote the universe of repositories. A repository \(P \in \mathcal{P}\) is +-- modeled as a pair: +-- +-- \[ +-- P = (D, S) +-- \] +-- +-- where \(D\) represents the __domain logic__ (the algorithmic core, modules, data types, and +-- mathematical structures inhabiting @src/@, @app/@, @lib/@) and \(S\) represents the __scaffolding__ +-- (build tool manifests, documentation, git hooks, CI matrices, and verification harnesses). +-- +-- === The Inviolable Conservation Law of Domain Logic +-- +-- Any retrofitting transformation \(R : \mathcal{P} \to \mathcal{P}\) must strictly satisfy the +-- __Conservation of Domain Logic__: +-- +-- \[ +-- \pi_{\text{domain}}(R(P)) = \pi_{\text{domain}}(P) +-- \] +-- +-- That is, no retrofitting operation may ever delete, truncate, overwrite, or mutate any domain +-- logic file. All standardization occurs exclusively in the scaffolding component \(S\). +-- +-- == 2. Phased Stratification of the Retrofitting Pipeline +-- +-- To guarantee safety and transparency, the retrofitting engine decomposes into four +-- phased operational milestones across Phase 4: +-- +-- * __Milestone 4.1 (Diagnostic Repository Inspector):__ +-- Strictly observational, read-only static analysis. Evaluates the target repository across +-- six orthogonal dimensions, producing a strongly typed 'DiagnosticReport' and quantitative +-- retrofit readiness score \(S(P) \in [0.0, 100.0]\). +-- +-- * __Milestone 4.2 (Non-Destructive Skeleton Overlay):__ +-- Synthesizes missing ecosystem infrastructure: @.githooks/@, @.gitmessage@, turnkey verification +-- harnesses (@bin/*-verify@, @bin/*-tagref@, @bin/*-linkcheck@, @bin/*-cloc@), documentation +-- skeletons (@docs/INDEX.md@, @docs/notes/*_DESIGN.md@, @docs/notes/DOC_STRATEGY.md@), and +-- agent operational layers (@PLAN.md@, @STATE.md@, @AGENTS.md@). +-- +-- * __Milestone 4.3 (Progressive Quality Gate Realization):__ +-- Incremental quality remediation stepping through four compliance levels: +-- - Level 0: Toolchain and verification harness installation. +-- - Level 1: Tagref and Markdown link integrity certification. +-- - Level 2: Build warnings resolved under @-Wall -Wcompat@. +-- - Level 3: HLint hints completely eliminated under zero-hint policy. +-- +-- * __Milestone 4.4 (Empirical Victim Project Crucible):__ +-- End-to-end validation against real-world targets, beginning with @~/src/gongju/@ ("tools/implement"). +-- +-- == 3. The Six Orthogonal Diagnostic Dimensions +-- +-- The diagnostic analyzer ('scanRepository') evaluates target workspaces across six dimensions: +-- +-- @ +-- +-------------------------------------------------------------------------------+ +-- | Six Diagnostic Dimensions | +-- +-------------------------------------------------------------------------------+ +-- | [1] Language Stacks : Haskell, Rust, C/C++, Python, Shell (File counts & %) | +-- | [2] Build Systems : Cabal Multi/Single, Stack, Cargo, CMake, Make, Meson | +-- | [3] Test Infra : Hspec, Tasty, QuickCheck, Cargo test, Pytest, CTest | +-- | [4] Documentation Gaps : DOC_STRATEGY.md Checklist (Critical, Recommended) | +-- | [5] Git Governance : .githooks, commit-msg RFC 2822 trailers, .gitmessage | +-- | [6] Quality Gates : Turnkey verify runner, Tagref, Linkcheck, CLOC gate | +-- +-------------------------------------------------------------------------------+ +-- @ +-- +-- == 4. Quantitative Readiness Scoring Formula +-- +-- The ecosystem retrofit readiness score \(S(P)\) is a weighted sum normalized to \([0.0, 100.0]\): +-- +-- \[ +-- S(P) = w_{\text{lang}} \cdot s_{\text{lang}} +-- + w_{\text{test}} \cdot s_{\text{test}} +-- + w_{\text{doc}} \cdot s_{\text{doc}} +-- + w_{\text{git}} \cdot s_{\text{git}} +-- + w_{\text{verif}} \cdot s_{\text{verif}} +-- \] +-- +-- where: +-- * \(w_{\text{lang}} = 15\%\): Clear primary language and coherent build manifest. +-- * \(w_{\text{test}} = 20\%\): Active test directories (10%) and declared suites with frameworks (10%). +-- * \(w_{\text{doc}} = 30\%\): Proportion of present Critical and Recommended documents per @DOC_STRATEGY.md@. +-- * \(w_{\text{git}} = 20\%\): Git repository (5%), .githooks (5%), commit-msg with attribution (5%), template (5%). +-- * \(w_{\text{verif}} = 15\%\): Turnkey verify runner (5%), Tagref (3%), Linkcheck (3%), CLOC (2%), Linters (2%). +-- +-- = Worked Example +-- +-- >>> import Gachi.Retrofit +-- >>> report <- scanRepository "." +-- >>> diagProjectName report +-- "gachi" +-- >>> diagRetrofitScore report >= 90.0 +-- True +-- >>> let dashboard = formatDiagnosticReport report +-- >>> T.null dashboard +-- False +module Gachi.Retrofit + ( -- * Re-exports from Gachi.Retrofit.Diagnostic + scanRepository + , detectLanguages + , detectBuildSystems + , detectTestInfrastructure + , detectDocumentationGaps + , detectGitGovernance + , detectVerificationHarnesses + , computeRetrofitScore + , computeRemediationPlan + , inferProjectName + , listRepositoryFiles + , isIgnoredDirectory + + -- * Re-exports from Gachi.Retrofit.Report + , formatDiagnosticReport + , formatDiagnosticMarkdown + , formatDiagnosticSummaryLine + , renderScoreBar + , scoreClassification + , padRight + + -- * Re-exports from Gachi.Retrofit.Overlay + , OverlayActionType(..) + , OverlayCategory(..) + , OverlayAction(..) + , GitGovernanceAction(..) + , OverlayPlan(..) + , OverlayResult(..) + , computeOverlayPlan + , synthesizeOverlayCandidates + , detectGitAuthor + , executeOverlayPlan + , overlayRepository + , formatOverlayPlan + , formatOverlayPlanMarkdown + , formatOverlayResult + , overlayCategoryName + + -- * Re-exports from Gachi.Retrofit.Types + , Language(..) + , LanguageStats(..) + , languageName + , BuildSystem(..) + , WorkspaceLayout(..) + , buildSystemName + , layoutName + , TestFramework(..) + , TestSuiteInfo(..) + , TestInfrastructure(..) + , testFrameworkName + , DocCategory(..) + , DocSeverity(..) + , DocGap(..) + , docCategoryName + , docSeverityName + , GitGovernanceStatus(..) + , VerificationHarnessStatus(..) + , DiagnosticReport(..) + + -- * Re-exports from Gachi.Retrofit.QualityGate (Milestone 4.3) + , QualityLevel(..) + , qualityLevelName + , qualityLevelOrdinal + , GateCheck(..) + , GateResult(..) + , QualityGateReport(..) + , RemediationStep(..) + , RemediationPriority(..) + , remediationPriorityName + , level0Gates + , level1Gates + , level2Gates + , level3Gates + , allLevelGates + , evaluateQualityGates + , evaluateGateCheck + , computeAchievedLevel + , computeRemediationSteps + , formatQualityGateReport + , formatQualityGateMarkdown + ) where + +import Gachi.Retrofit.Diagnostic +import Gachi.Retrofit.Overlay +import Gachi.Retrofit.QualityGate +import Gachi.Retrofit.Report +import Gachi.Retrofit.Types diff --git a/src/Gachi/Retrofit/Diagnostic.hs b/src/Gachi/Retrofit/Diagnostic.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Retrofit/Diagnostic.hs @@ -0,0 +1,936 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Module: Gachi.Retrofit.Diagnostic +-- Description: Diagnostic repository inspector and static analysis engine +-- +-- This module implements the static analysis engine for inspecting arbitrary +-- codebases (Milestone 4.1, Phase 4). It performs strictly read-only diagnostics +-- across languages, build systems, test suites, documentation, git hooks, and +-- verification harnesses. +-- +-- = Architectural Context & Invariants +-- +-- Note [Non-Destructive Skeleton Overlay] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- [tag:note-nondestructive-retrofit] +-- The Non-Destructive Codebase Retrofitting engine ('gachi retrofit') adopts legacy, +-- single-package, or foreign repositories into the canonical multi-package ecosystem +-- hierarchy (~/src/PLAN.md §1.A, Phase 4). +-- +-- Core Invariants: +-- 1. __Preservation of Domain Logic:__ Retrofitting operations must never delete, +-- overwrite, or mutate existing domain source files located in @src/@, @app/@, +-- @lib/@, or domain-specific subdirectories. +-- 2. __Pure Observational Diagnosis:__ Milestone 4.1 performs strictly read-only +-- static analysis across six orthogonal dimensions (languages, build systems, +-- test infrastructure, @DOC_STRATEGY.md@ gaps, Git hooks, verification gates) +-- before any mutation or overlay is considered. +-- 3. __Progressive Realization:__ Quality gates are phased incrementally: +-- - Level 0: Scaffolding, documentation skeletons, and verification harnesses. +-- - Level 1: Tagref cross-references and Markdown link integrity. +-- - Level 2: Clean build under @-Wall -Wcompat -Wredundant-constraints@. +-- - Level 3: HLint hints completely eliminated (zero-hint policy). +-- +-- Note [Arbitrary Target Codebase Language Classification and Extension Semantics] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Automated language classification across arbitrary codebases presents unique challenges: +-- 1. __Pruning Build Artifacts:__ Repositories frequently contain thousands of generated +-- files (e.g. @dist-newstyle@, @node_modules@, @target@, @.stack-work@, @__pycache__@). +-- The crawler explicitly prunes these directories prior to extension matching to prevent +-- skewed distributions or out-of-memory traversal. +-- 2. __Polyglot Workspaces:__ Large systems combine multiple language runtimes (e.g. +-- Haskell core logic, Rust foreign function bindings, C runtime drivers, Python scripts). +-- The scanner computes absolute file counts and proportional percentages across all +-- detected languages, identifying the primary language by relative majority. +-- 3. __Header Disambiguation:__ C and C++ header files (@.h@, @.hpp@) are tracked with +-- their respective language families to provide an accurate overview of native subsystems. +-- +-- Note [Test Infrastructure Discovery and Framework Introspection] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Rather than executing untrusted test scripts during diagnostic inspection, the analyzer +-- performs static introspection: +-- 1. Discovers standard test directories (@test/@, @tests/@, @spec/@). +-- 2. Scans test source files for known testing framework modules (@Test.Hspec@, @Test.Tasty@, +-- @Test.QuickCheck@, @Hedgehog@, @pytest@, @cargo test@). +-- 3. Identifies declared test targets and reports whether the repository possesses active +-- automated quality gates. +-- +-- Note [DOC_STRATEGY.md Corpus Adherence and Gap Categorization] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The canonical documentation strategy (@DOC_STRATEGY.md@ §1) establishes that documentation +-- serves distinct audiences with strictly defined fact classes and canonicity. +-- The diagnostic inspector evaluates repositories against this checklist, categorizing +-- missing documents by severity: +-- * __Critical:__ @README.md@ (arrival orientation) and @LICENSE@ (legal terms). +-- * __Recommended:__ @PLAN.md@ / @STATE.md@ (session loop), @AGENTS.md@ (agent advisory), +-- @docs/INDEX.md@ (reading paths), @docs/notes/DOC_STRATEGY.md@ (policy), and +-- @docs/notes/COMMIT_ATTRIBUTION.md@ (RFC 2822 trailer rules). +-- * __Optional:__ @CLAUDE.md@ (symlinks), @CHANGELOG.md@, and tutorial tracks. +-- +-- Note [Git Governance, Hook Executability, and RFC 2822 Trailer Verification] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- To maintain clean copyright and attribution boundaries across the ecosystem, Git hooks +-- enforce strict commit trailer policies: +-- 1. __Trailer Format:__ AI coding assistants must be attributed using RFC 2822 trailers +-- (e.g. @Assisted-by: Antigravity (Google / gemini-3.8-pro)@). +-- 2. __Legal Boundaries:__ AI assistants must NEVER be recorded as @Co-authored-by:@ +-- (which implies legal joint copyright authorship) or @Signed-off-by:@ (which certifies +-- the human Developer Certificate of Origin). +-- 3. __Hook Validation:__ The inspector validates that @commit-msg@ exists, has POSIX +-- Note [Heuristic Project Name and Workspace Topography Resolution] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Determining the identity and canonical slug of an arbitrary codebase requires a deterministic +-- resolution ladder: +-- 1. __Direct Manifest Discovery:__ If a single @*.cabal@ manifest exists at the root level +-- (e.g. @victim.cabal@), its basename defines the canonical project name. +-- 2. __Multi-Package Workspace Fallback:__ If a multi-package workspace definition (@cabal.project@) +-- is present, individual child package manifests in @packages/*/@ must not be confused with +-- the parent project. In this scenario, the normalized directory basename of the workspace +-- root (e.g. @"gachi"@) serves as the authoritative project identifier. +-- 3. __Absolute Path Canonicalization:__ The scanner resolves relative target paths (e.g. @.@) +-- via 'makeAbsolute' prior to name extraction, ensuring robust identification across subpackage +-- invocations. +-- +-- Note [Comprehensive Six-Pillar Diagnostic Scoring Formula] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The diagnostic evaluation culminates in a quantitative retrofit score S(P) in [0.0, 100.0]: +-- 1. __Languages & Toolchains (15%):__ Rewards clear language identification (Haskell, Rust, etc.) +-- and recognized declarative build manifests (@cabal.project@, @Cargo.toml@). +-- 2. __Test Infrastructure (20%):__ Evaluates test directories (@test/@, @spec/@), declared suites, +-- and recognized testing frameworks (@Test.Hspec@, @Test.Tasty@, @pytest@). +-- 3. __Documentation Integrity (30%):__ Proportionally scores presence of Critical and Recommended +-- assets per @DOC_STRATEGY.md@ §1. +-- 4. __Git Governance & Attribution (20%):__ Evaluates @.git@, @.githooks@, executable @commit-msg@ +-- with RFC 2822 @Assisted-by:@ trailer validation, and @.gitmessage@ commit template pinning. +-- 5. __Verification Harnesses (15%):__ Checks presence and executability of turnkey @bin/*-verify@, +-- Tagref runner, Markdown linkcheck, and CLOC comment density audit scripts. +-- +-- Note [Remediation Action Priority Ordering and Phase 4 Transition] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The diagnostic analyzer transforms localized defects into an ordered remediation plan: +-- 1. __Sovereign Git Governance:__ Bootstrapping @.githooks@ and commit trailer enforcement must +-- precede any file mutations to guarantee attribution integrity from the first commit. +-- 2. __Physical Verification Harnesses:__ Turnkey test runners (@bin/*-verify@) are provisioned +-- next so every subsequent transformation can be verified immediately. +-- 3. __Critical Documentation Scaffolding:__ @README.md@ and @LICENSE@ establish legal and +-- operational identity. +-- 4. __Recommended Operational Governance:__ @PLAN.md@, @STATE.md@, and @AGENTS.md@ establish +-- the two-file loop and AI assistant boundaries. +-- 5. __Test Suite & Layout Modernization:__ Establishes baseline test coverage and guides +-- single-package repositories toward multi-package workspace modularity. +-- +-- Note [Safe Recursive Filesystem Crawling with Zero Allocations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Arbitrary checkouts frequently contain deep recursive structures, broken symlinks, or +-- million-file generated directories (e.g. @node_modules@, @dist-newstyle@, @.stack-work@). +-- To maintain sub-second response times and zero memory exhaustion: +-- 1. __Pre-Descent Pruning:__ The crawler matches directory basenames against 'ignoredDirectories' +-- before calling 'listDirectory', completely preventing traversal of massive trees. +-- 2. __Exception Containment:__ File permission exceptions and dangling symlinks are swallowed +-- gracefully via 'catch', allowing partial audits of restricted file trees. +-- 3. __Relative Path Normalization:__ All discovered paths are returned relative to the root, +-- enabling deterministic matching against canonical templates. +-- +-- = Worked Example +-- +-- >>> report <- scanRepository "." +-- >>> diagProjectName report +-- "gachi" +-- >>> diagRetrofitScore report >= 50.0 +-- True +module Gachi.Retrofit.Diagnostic + ( -- * High-Level Scanner + scanRepository + + -- * Dimension Analyzers + , detectLanguages + , detectBuildSystems + , detectTestInfrastructure + , detectDocumentationGaps + , detectGitGovernance + , detectVerificationHarnesses + + -- * Scoring & Remediation Planning + , computeRetrofitScore + , computeRemediationPlan + , inferProjectName + + -- * Filesystem Traversal + , listRepositoryFiles + , isIgnoredDirectory + ) where + +import Control.Exception (SomeException, catch) +import Data.Char (toLower) +import Data.List (isPrefixOf, isSuffixOf, nub, partition, sortBy) +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust, mapMaybe) +import Data.Ord (comparing) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import System.Directory + ( doesDirectoryExist + , doesFileExist + , executable + , getPermissions + , listDirectory + , makeAbsolute + ) +import System.Exit (ExitCode(..)) +import System.FilePath (dropTrailingPathSeparator, takeDirectory, takeExtension, takeFileName, ()) +import System.Process (readProcessWithExitCode) + +import Gachi.Retrofit.Types + +-------------------------------------------------------------------------------- +-- 1. Filesystem Traversal +-------------------------------------------------------------------------------- + +-- | Directory basenames intentionally skipped during diagnostic exploration to avoid +-- infinite loops, deep virtualenvs, or massive build artifacts. +ignoredDirectories :: [String] +ignoredDirectories = + [ ".git" + , "dist-newstyle" + , ".stack-work" + , "target" + , "node_modules" + , "__pycache__" + , ".venv" + , "venv" + , "env" + , ".cabal-sandbox" + , ".direnv" + , "dist" + , "_build" + , ".tox" + ] + +-- | Predicate checking whether a directory path should be ignored during traversal. +-- +-- Matches known build artifact directories and temporary scratch paths starting +-- with @.tmp@. +-- +-- === Examples +-- +-- >>> isIgnoredDirectory "dist-newstyle" +-- True +-- >>> isIgnoredDirectory "src" +-- False +isIgnoredDirectory :: FilePath -> Bool +isIgnoredDirectory dirName = + let base = takeFileName (dropTrailingPathSeparator dirName) + in base `elem` ignoredDirectories || ".tmp" `isPrefixOf` base + +-- | Recursively traverses a target directory collecting relative file paths. +-- +-- Automatically prunes ignored directories ('isIgnoredDirectory') and gracefully +-- recovers from filesystem permission errors, broken symlinks, or transient I/O faults. +-- Returns relative paths normalized against the inspected directory root. +listRepositoryFiles :: FilePath -> IO [FilePath] +listRepositoryFiles root = go "" + where + go relDir = do + let fullDir = if null relDir then root else root relDir + isDir <- doesDirectoryExist fullDir `catch` (\(_ :: SomeException) -> pure False) + if not isDir || (not (null relDir) && isIgnoredDirectory relDir) + then pure [] + else do + entries <- listDirectory fullDir `catch` (\(_ :: SomeException) -> pure []) + concatMapM (processEntry relDir) entries + + processEntry relDir entry + | isIgnoredDirectory entry = pure [] + | otherwise = do + let relPath = if null relDir then entry else relDir entry + fullPath = root relPath + isDir <- doesDirectoryExist fullPath `catch` (\(_ :: SomeException) -> pure False) + if isDir + then go relPath + else pure [relPath] + + concatMapM f xs = fmap concat (mapM f xs) + +-------------------------------------------------------------------------------- +-- 2. Programming Language Detection +-------------------------------------------------------------------------------- + +-- | Maps a file extension to its corresponding programming language. +-- +-- Covers Haskell, Rust, C, C++, Python, Shell, OCaml, Go, Java, JavaScript, and TypeScript. +classifyExtension :: String -> Maybe (Language, Text) +classifyExtension ext = case map toLower ext of + ".hs" -> Just (LangHaskell, ".hs") + ".lhs" -> Just (LangHaskell, ".lhs") + ".rs" -> Just (LangRust, ".rs") + ".c" -> Just (LangC, ".c") + ".h" -> Just (LangC, ".h") + ".cpp" -> Just (LangCpp, ".cpp") + ".cc" -> Just (LangCpp, ".cc") + ".cxx" -> Just (LangCpp, ".cxx") + ".hpp" -> Just (LangCpp, ".hpp") + ".hxx" -> Just (LangCpp, ".hxx") + ".py" -> Just (LangPython, ".py") + ".sh" -> Just (LangShell, ".sh") + ".bash" -> Just (LangShell, ".bash") + ".zsh" -> Just (LangShell, ".zsh") + ".ml" -> Just (LangOCaml, ".ml") + ".mli" -> Just (LangOCaml, ".mli") + ".go" -> Just (LangGo, ".go") + ".java" -> Just (LangJava, ".java") + ".js" -> Just (LangJavaScript, ".js") + ".mjs" -> Just (LangJavaScript, ".mjs") + ".cjs" -> Just (LangJavaScript, ".cjs") + ".ts" -> Just (LangTypeScript, ".ts") + ".tsx" -> Just (LangTypeScript, ".tsx") + _ -> Nothing + +-- | Purely analyzes a collection of repository file paths to determine programming +-- language distributions, file counts, and percentage breakdowns. +-- +-- Groups recognized files by 'Language', sums occurrences, computes percentage +-- share relative to total recognized source files, and sorts descending by file count. +-- +-- === Examples +-- +-- >>> let stats = detectLanguages ["src/A.hs", "src/B.hs", "native/c.rs"] +-- >>> length stats +-- 2 +-- >>> langFiles (head stats) +-- 2 +detectLanguages :: [FilePath] -> [LanguageStats] +detectLanguages paths = + let recognized = mapMaybe (classifyExtension . takeExtension) paths + totalCount = length recognized + grouped = foldr insertLang Map.empty recognized + statsList = Map.foldrWithKey (buildStat totalCount) [] grouped + in sortBy (comparing (negate . langFiles)) statsList + where + insertLang (lang, ext) m = + let (cnt, exts) = Map.findWithDefault (0, []) lang m + in Map.insert lang (cnt + 1, if ext `elem` exts then exts else ext : exts) m + + buildStat total lang (cnt, exts) acc = + let pct = if total > 0 then (fromIntegral cnt / fromIntegral total) * 100.0 else 0.0 + stat = LanguageStats + { langType = lang + , langFiles = cnt + , langPercentage = fromIntegral (round (pct * 10 :: Double) :: Int) / 10.0 + , langExtensions = exts + } + in stat : acc + +-------------------------------------------------------------------------------- +-- 3. Build Systems & Layout Detection +-------------------------------------------------------------------------------- + +-- | Detects build tool manifests and classifies the repository workspace layout. +-- +-- === Build Manifest Detection Mechanics +-- +-- The analyzer inspects file paths across two topological tiers: +-- 1. __Root Manifests:__ Checks whether authoritative manifests inhabit the repository +-- root directory: +-- - Cabal Workspace: @cabal.project@ establishes multi-package boundaries. +-- - Single Cabal Package: Any @*.cabal@ residing directly in @takeDirectory p == "."@. +-- - Stack Project: @stack.yaml@ defines curated Stackage resolver pins. +-- - Hpack Specification: @package.yaml@ generates @*.cabal@ dynamically. +-- - Rust Cargo: @Cargo.toml@ specifies package or virtual workspace dependencies. +-- - CMake: @CMakeLists.txt@ defines cross-platform native builds. +-- - Make: Standard @Makefile@, @makefile@, or @GNUmakefile@. +-- - Meson: @meson.build@ provides high-speed Ninja-based builds. +-- - Python Packaging: @pyproject.toml@, @setup.py@, @setup.cfg@, @requirements.txt@. +-- - Nix Expressions: @flake.nix@ and @default.nix@ establish hermetic sandbox builds. +-- +-- 2. __Subpackage Traversal:__ +-- Discovers nested packages within @packages/*/*.cabal@, signaling modern multi-package +-- workspaces. +-- +-- === Layout Classification Semantics +-- +-- The discovered manifests determine the 'WorkspaceLayout': +-- * 'LayoutMultiPackage': Segregated packages in @packages/*/@. The ideal topology for +-- Gachi ecosystem integration. +-- * 'LayoutSinglePackage': Standalone library or tool located at root. Retrofitting +-- recommends migrating to multi-package modularity when scaling. +-- * 'LayoutPolyglot': Co-existence of multiple heterogeneous build systems (e.g. +-- Haskell + Rust FFI or C + Python bindings). Requires partitioned CI workflows. +-- * 'LayoutUnstructured': Raw source files discovered without any declarative manifest. +-- Requires baseline build system synthesis. +-- +-- === Examples +-- +-- >>> let (builds, layout) = detectBuildSystems "." ["cabal.project", "packages/core/core.cabal"] +-- >>> layout +-- LayoutMultiPackage +-- >>> BuildCabalProject `elem` builds +-- True +detectBuildSystems :: FilePath -> [FilePath] -> ([BuildSystem], WorkspaceLayout) +detectBuildSystems _root paths = + let manifests = findBuildManifests paths + layout = classifyLayout paths manifests + in (manifests, layout) + where + findBuildManifests ps = + let hasRoot name = name `elem` ps + hasRootSuffix sfx = any (\p -> takeDirectory p == "." && sfx `isSuffixOf` p) ps + hasSubCabal = any (\p -> "packages" `isPrefixOf` p && ".cabal" `isSuffixOf` p) ps + + cabalProj = [BuildCabalProject | hasRoot "cabal.project"] + cabalPkg = [BuildCabalPackage | hasRootSuffix ".cabal" || hasSubCabal] + stack = [BuildStack | hasRoot "stack.yaml"] + hpack = [BuildHpack | hasRoot "package.yaml"] + cargo = [BuildCargo | hasRoot "Cargo.toml"] + cmake = [BuildCMake | hasRoot "CMakeLists.txt"] + make = [BuildMake | any (`elem` ps) ["Makefile", "makefile", "GNUmakefile"]] + meson = [BuildMeson | hasRoot "meson.build"] + poetry = [BuildPoetry | hasRoot "pyproject.toml"] + setuptools = [BuildSetuptools | hasRoot "setup.py" || hasRoot "setup.cfg"] + pip = [BuildPip | hasRoot "requirements.txt"] + nix = [BuildNix | hasRoot "flake.nix" || hasRoot "default.nix"] + in cabalProj ++ cabalPkg ++ stack ++ hpack ++ cargo ++ cmake ++ make ++ meson ++ poetry ++ setuptools ++ pip ++ nix + + classifyLayout ps manifests + | any (\p -> "packages/" `isPrefixOf` p) ps = LayoutMultiPackage + | isPolyglot manifests = LayoutPolyglot + | not (null manifests) = LayoutSinglePackage + | otherwise = LayoutUnstructured + + isPolyglot ms = + let hasHaskell = any (`elem` [BuildCabalProject, BuildCabalPackage, BuildStack, BuildHpack]) ms + hasRust = BuildCargo `elem` ms + hasC = any (`elem` [BuildCMake, BuildMake, BuildMeson]) ms + hasPy = any (`elem` [BuildPoetry, BuildFlit, BuildSetuptools, BuildPip]) ms + count = length (filter id [hasHaskell, hasRust, hasC, hasPy]) + in count > 1 + +-------------------------------------------------------------------------------- +-- 4. Test Infrastructure Detection +-------------------------------------------------------------------------------- + +-- | Identifies test directories, declared test suites, and testing frameworks. +-- +-- === Static Test Introspection Mechanics +-- +-- The analyzer inspects repository file paths to detect automated test infrastructure +-- without compiling or running external scripts: +-- +-- 1. __Directory Detection:__ Discovers directories dedicated to testing (@test/@, @tests/@, +-- @spec/@, or subpackage test paths such as @packages/*/test/@). +-- 2. __Test File Counting:__ Identifies test source files matching standard conventions: +-- - Haskell: Files named @*Spec.hs@, @*Test.hs@, or residing inside a @test/@ directory. +-- - Rust: Files containing @"test"@ or residing inside a @tests/@ integration test folder. +-- - Python: Files matching @test_*.py@ or @*_test.py@. +-- 3. __Framework Keyword Introspection:__ Samples discovered test files (up to 5) to inspect +-- their module imports and text content, detecting testing frameworks: +-- - 'FrameworkHspec': BDD testing via @Test.Hspec@. +-- - 'FrameworkTasty': Test runner via @Test.Tasty@. +-- - 'FrameworkQuickCheck': Property testing via @Test.QuickCheck@. +-- - 'FrameworkHedgehog': Integrated property testing via @Hedgehog@. +-- - 'FrameworkCargoTest': Built-in Rust test attributes. +-- - 'FrameworkPytest': Python pytest framework. +-- +-- Returns a 'TestInfrastructure' record containing test directories, file counts, and +-- identified frameworks. +detectTestInfrastructure :: FilePath -> [FilePath] -> [BuildSystem] -> IO TestInfrastructure +detectTestInfrastructure root paths _buildSystems = do + let testDirs = filter isTestDirectory paths + uniqueDirs = nub (map takeDirectory testDirs) + testFiles = filter isTestFile paths + hasAnyTests = not (null testDirs) || not (null testFiles) + + -- Scan discovered test files for framework imports + discoveredFrameworks <- inspectTestFiles root testFiles + let suites = + [ TestSuiteInfo + { testSuiteName = "test" + , testSuitePath = case uniqueDirs of + (d:_) -> d + [] -> "test" + , testFrameworks = discoveredFrameworks + } + | hasAnyTests + ] + + pure TestInfrastructure + { hasTests = hasAnyTests + , testSuites = suites + , testDirectories = uniqueDirs + , testFileCount = length testFiles + } + where + isTestDirectory p = + let d = takeDirectory p + in d == "test" || d == "tests" || d == "spec" || "/test" `isInfixOf` d || "/tests" `isInfixOf` d + + isTestFile p = + let f = takeFileName p + in (takeExtension p == ".hs" && ("Spec.hs" `isSuffixOf` f || "Test.hs" `isSuffixOf` f || takeDirectory p == "test")) + || (takeExtension p == ".rs" && ("test" `isInfixOf` f || takeDirectory p == "tests")) + || (takeExtension p == ".py" && ("test_" `isPrefixOf` f || "_test.py" `isSuffixOf` f)) + + inspectTestFiles _ [] = pure [] + inspectTestFiles r files = do + let sample = take 5 files + contents <- mapM (\f -> TIO.readFile (r f) `catch` (\(_ :: SomeException) -> pure "")) sample + let allText = T.unwords contents + hspec = [FrameworkHspec | "hspec" `T.isInfixOf` T.toLower allText || "Test.Hspec" `T.isInfixOf` allText] + tasty = [FrameworkTasty | "tasty" `T.isInfixOf` T.toLower allText || "Test.Tasty" `T.isInfixOf` allText] + qc = [FrameworkQuickCheck | "quickcheck" `T.isInfixOf` T.toLower allText] + hedge = [FrameworkHedgehog | "hedgehog" `T.isInfixOf` T.toLower allText] + pytest = [FrameworkPytest | "pytest" `T.isInfixOf` T.toLower allText] + cargo = [FrameworkCargoTest | any (\f -> takeExtension f == ".rs") files] + pure (nub (hspec ++ tasty ++ qc ++ hedge ++ pytest ++ cargo)) + + isInfixOf needle haystack = needle `isPrefixOf` haystack || case haystack of + (_:rest) -> needle `isInfixOf` rest + [] -> False + +-------------------------------------------------------------------------------- +-- 5. Documentation Gaps Analysis +-------------------------------------------------------------------------------- + +-- | Specification of canonical documentation items per @DOC_STRATEGY.md@. +-- +-- Establishes the authoritative inventory of twelve standard documentation assets, +-- categorized by purpose and prioritized by severity. +canonicalDocChecklist :: [(FilePath, DocCategory, DocSeverity, Text)] +canonicalDocChecklist = + [ ( "README.md" + , DocOrientation + , SeverityCritical + , "Orientation and project entry point for newcomers and users." + ) + , ( "docs/INDEX.md" + , DocCorpusInventory + , SeverityRecommended + , "Curated corpus inventory and reading paths per DOC_STRATEGY.md §1." + ) + , ( "docs/notes/DOC_STRATEGY.md" + , DocStrategy + , SeverityRecommended + , "Canonical documentation policy, genres, and precedence rules." + ) + , ( "docs/notes/COMMIT_ATTRIBUTION.md" + , DocAttribution + , SeverityRecommended + , "Commit trailer specification (RFC 2822 Assisted-by: trailers)." + ) + , ( "PLAN.md" + , DocGovernance + , SeverityRecommended + , "Strategic roadmap and phase milestone tracking (the two-file loop)." + ) + , ( "STATE.md" + , DocGovernance + , SeverityRecommended + , "Active session frontier and verification status (the two-file loop)." + ) + , ( "AGENTS.md" + , DocAdvisory + , SeverityRecommended + , "Bounded AI assistant operational context and modular rules pointer." + ) + , ( "CLAUDE.md" + , DocAdvisory + , SeverityOptional + , "Compatibility pointer symlink to AGENTS.md." + ) + , ( "docs/TUTORIAL.md" + , DocTutorial + , SeverityOptional + , "End-to-end tutorial track with worked examples." + ) + , ( "docs/MAINTAINER_GUIDE.md" + , DocOperational + , SeverityRecommended + , "Maintainer operational manual: release lifecycle, gates, and triage." + ) + , ( "CHANGELOG.md" + , DocChangelog + , SeverityOptional + , "Chronological version history and notable release changes." + ) + , ( "LICENSE" + , DocChangelog + , SeverityCritical + , "Open source licensing terms (e.g. EUPL-1.2 or Apache-2.0)." + ) + ] + +-- | Evaluates presence of canonical documentation files against @DOC_STRATEGY.md@. +-- +-- === Documentation Fact Classes & Canonicity +-- +-- In accordance with @DOC_STRATEGY.md@ §1, documentation is partitioned into strict fact +-- classes to prevent documentation drift: +-- +-- 1. __Arrivals (@README.md@):__ +-- Orientation facts only. Always defers to canonical design notes for technical claims. +-- 2. __Curated Corpus Inventory (@docs/INDEX.md@):__ +-- Comprehensive catalog of all documents, their reading order, fact classes, and authority. +-- 3. __Policy & Authority (@docs/notes/DOC_STRATEGY.md@):__ +-- Corpus rules, lifecycle, and the Precedence Rule ("code wins at runtime; notes corrected regardless"). +-- 4. __Attribution Invariants (@docs/notes/COMMIT_ATTRIBUTION.md@):__ +-- Linux kernel RFC 2822 trailer format for human authors and AI coding assistants. +-- 5. __Governance & Session Frontiers (@PLAN.md@, @STATE.md@):__ +-- The Two-File Loop: tracking operational roadmap milestones and active session state. +-- 6. __Agent Advisory Layer (@AGENTS.md@):__ +-- Bounded (~4 KB) pointer projection into canonical documents, preventing context degradation. +-- +-- Compares repository file paths against 'canonicalDocChecklist', recognizing +-- standard variations (e.g. @LICENSE.md@ or @LICENSE.txt@ for @LICENSE@). +detectDocumentationGaps :: FilePath -> [FilePath] -> [DocGap] +detectDocumentationGaps _root paths = + map checkItem canonicalDocChecklist + where + checkItem (path, cat, sev, advice) = + let present = path `elem` paths || (path == "LICENSE" && any (\p -> p == "LICENSE.md" || p == "LICENSE.txt") paths) + in DocGap + { docPath = path + , docCategory = cat + , docPresent = present + , docSeverity = sev + , docAdvice = advice + } + +-------------------------------------------------------------------------------- +-- 6. Git Governance & Attribution Conformance +-------------------------------------------------------------------------------- + +-- | Inspects Git repository state, hook paths, and commit trailer validation. +-- +-- === Git Governance Invariants +-- +-- Audits whether the repository conforms to ecosystem source control standards: +-- +-- 1. __Repository Initialization:__ Verifies presence of the @.git@ directory at the root. +-- 2. __Dedicated Hooks Directory:__ Validates existence of @.githooks/@ and queries ambient +-- Git configuration (@git config core.hooksPath@) to confirm hooks are pinned to version +-- control rather than local unstaged @.git/hooks/@. +-- 3. __Executable Commit-Msg Hook:__ Confirms presence and POSIX executable bits (+x) for +-- @commit-msg@. +-- 4. __RFC 2822 Trailer Validation:__ Scans @commit-msg@ script logic to certify that +-- Sarutahiko / RFC 2822 @Assisted-by:@ trailers are validated and enforced, while rejecting +-- illicit AI @Co-authored-by:@ and @Signed-off-by:@ tags. +-- 5. __Executable Pre-Commit Hook:__ Confirms presence and executable bits (+x) for @pre-commit@, +-- which runs Tagref, linkcheck, or formatting pre-checks. +-- 6. __Commit Template Pinning:__ Checks presence of @.gitmessage@ and queries Git +-- configuration (@git config commit.template@) to ensure contributors are guided by the +-- standard HEREDOC commit format. +detectGitGovernance :: FilePath -> IO GitGovernanceStatus +detectGitGovernance root = do + hasGit <- doesDirectoryExist (root ".git") `catch` (\(_ :: SomeException) -> pure False) + hasHooks <- doesDirectoryExist (root ".githooks") `catch` (\(_ :: SomeException) -> pure False) + + hooksCfg <- queryGitConfig root "core.hooksPath" + templateCfg <- queryGitConfig root "commit.template" + + -- Inspect commit-msg hook + let commitMsgPath = if hasHooks then root ".githooks" "commit-msg" else root ".git" "hooks" "commit-msg" + hasCommitMsg <- doesFileExist commitMsgPath `catch` (\(_ :: SomeException) -> pure False) + commitMsgExec <- if hasCommitMsg + then (executable <$> getPermissions commitMsgPath) `catch` (\(_ :: SomeException) -> pure False) + else pure False + commitMsgContent <- if hasCommitMsg + then TIO.readFile commitMsgPath `catch` (\(_ :: SomeException) -> pure "") + else pure "" + let hasAttributionCheck = "assisted-by" `T.isInfixOf` T.toLower commitMsgContent + || "sarutahiko" `T.isInfixOf` T.toLower commitMsgContent + || "rfc 2822" `T.isInfixOf` T.toLower commitMsgContent + + -- Inspect pre-commit hook + let preCommitPath = if hasHooks then root ".githooks" "pre-commit" else root ".git" "hooks" "pre-commit" + hasPreCommit <- doesFileExist preCommitPath `catch` (\(_ :: SomeException) -> pure False) + preCommitExec <- if hasPreCommit + then (executable <$> getPermissions preCommitPath) `catch` (\(_ :: SomeException) -> pure False) + else pure False + + -- Inspect .gitmessage template + hasTemplate <- doesFileExist (root ".gitmessage") `catch` (\(_ :: SomeException) -> pure False) + + pure GitGovernanceStatus + { hasGitRepo = hasGit + , hasHooksDir = hasHooks + , hooksPathConfig = hooksCfg + , hasCommitMsgHook = hasCommitMsg + , isCommitMsgExecutable = commitMsgExec + , hasCommitMsgAttributionCheck = hasAttributionCheck + , hasPreCommitHook = hasPreCommit + , isPreCommitExecutable = preCommitExec + , hasGitMessageTemplate = hasTemplate + , gitMessageConfig = templateCfg + } + where + queryGitConfig r key = do + (code, out, _) <- readProcessWithExitCode "git" ["-C", r, "config", key] "" `catch` (\(_ :: SomeException) -> pure (ExitFailure 1, "", "")) + case code of + ExitSuccess -> + let val = T.strip (T.pack out) + in pure (if T.null val then Nothing else Just val) + ExitFailure _ -> pure Nothing + +-------------------------------------------------------------------------------- +-- 7. Physical Verification Harnesses +-------------------------------------------------------------------------------- + +-- | Inspects physical verification scripts, Tagref, Linkcheck, and linters. +-- +-- === The Five Physical Verification Gates +-- +-- The Gachi quality model is founded on deterministic mechanical verification gates +-- that execute without external network dependencies: +-- +-- 1. __Gate 1 (HLint Static Linter):__ +-- Audits Haskell code with a zero-hint policy under @.hlint.yaml@. Guarantees clean idioms +-- and purges dead code patterns. +-- 2. __Gate 2 (Full Test Suite):__ +-- Executes all declared Cabal/Cargo/Python test suites with streamed assertion details. +-- 3. __Gate 3 (Tagref Cross-Reference Gate):__ +-- Evaluates @[tag:...]@ definitions and @[ref:...]@ references, certifying zero dangling +-- pointers and zero duplicate tags across code, comments, and documentation. +-- 4. __Gate 4 (Markdown Link & Anchor Integrity Gate):__ +-- Verifies all relative and absolute Markdown hyperlinks and section anchors, preventing +-- documentation drift and 404 dead ends. +-- 5. __Gate 5 (CLOC In-Code Comment Density Gate):__ +-- Audits in-code comment lines against total code lines, enforcing the minimum 25.0% +-- verification threshold and the 50.0%+ target on production source (@src/@). +-- +-- Inspects repository file paths to confirm whether turnkey runner scripts (@bin/*-verify@, +-- @bin/*-tagref@, @bin/*-linkcheck@, @bin/*-cloc@) and configurations (@tagref.yml@, +-- @.hlint.yaml@, @fourmolu.yaml@) exist. +detectVerificationHarnesses :: FilePath -> [FilePath] -> IO VerificationHarnessStatus +detectVerificationHarnesses _root paths = do + let verifyCandidates = filter (\p -> "bin/" `isPrefixOf` p && ("-verify" `isSuffixOf` p || p == "bin/verify")) paths + vPath = case verifyCandidates of + (vc:_) -> Just vc + [] -> Nothing + hasVerify = isJust vPath + + let hasTagrefCfg = "tagref.yml" `elem` paths || ".tagref" `elem` paths + hasTagrefHarn = any (\p -> "bin/" `isPrefixOf` p && ("-tagref" `isSuffixOf` p || p == "bin/tagref")) paths + hasLinkcheckHarn = any (\p -> "bin/" `isPrefixOf` p && ("-linkcheck" `isSuffixOf` p || p == "bin/linkcheck")) paths + hasClocHarn = any (\p -> "bin/" `isPrefixOf` p && ("-cloc" `isSuffixOf` p || p == "bin/cloc")) paths + hasHlint = ".hlint.yaml" `elem` paths + hasFourmolu = "fourmolu.yaml" `elem` paths + + pure VerificationHarnessStatus + { hasVerifyScript = hasVerify + , verifyScriptPath = vPath + , hasTagrefConfig = hasTagrefCfg + , hasTagrefHarness = hasTagrefHarn + , hasLinkcheckHarness = hasLinkcheckHarn + , hasClocHarness = hasClocHarn + , hasHlintConfig = hasHlint + , hasFourmoluConfig = hasFourmolu + } + +-------------------------------------------------------------------------------- +-- 8. Scoring & Remediation Planning +-------------------------------------------------------------------------------- + +-- | Computes a quantitative ecosystem retrofit readiness score (0.0 to 100.0). +-- +-- Weight distribution across diagnostic pillars: +-- * __Language & Build Systems (15%):__ Coherent language identification and manifest presence. +-- * __Test Infrastructure (20%):__ Test directories present (10%), declared suites with frameworks (10%). +-- * __Documentation Coverage (30%):__ Proportional presence of Critical and Recommended documents. +-- * __Git Governance & Hooks (20%):__ Git repository (5%), .githooks (5%), commit-msg with attribution (5%), pre-commit & template (5%). +-- * __Verification Quality Gates (15%):__ Turnkey verify runner (5%), Tagref (3%), Linkcheck (3%), CLOC (2%), Linters (2%). +computeRetrofitScore + :: [LanguageStats] + -> [BuildSystem] + -> TestInfrastructure + -> [DocGap] + -> GitGovernanceStatus + -> VerificationHarnessStatus + -> Double +computeRetrofitScore langs builds tests docs gitHarness verifHarness = + let -- Pillar 1: Language & Build System clarity (max 15.0) + -- Rewards presence of recognized programming languages and declarative manifests. + langScore = if not (null langs) && not (null builds) then 15.0 else 5.0 + + -- Pillar 2: Test Infrastructure (max 20.0) + -- 10.0 points for test directory or files; 10.0 points for recognized frameworks and declared suites. + testScore = (if hasTests tests then 10.0 else 0.0) + + (if not (null (testSuites tests)) then 10.0 else 0.0) + + -- Pillar 3: Canonical Documentation Coverage (max 30.0) + -- Proportion of required and recommended documents present per DOC_STRATEGY.md. + (reqDocs, _optDocs) = partition (\d -> docSeverity d /= SeverityOptional) docs + presentReq = length (filter docPresent reqDocs) + totalReq = max 1 (length reqDocs) + docScore = (fromIntegral presentReq / fromIntegral totalReq) * 30.0 + + -- Pillar 4: Sovereign Git Governance & Attribution (max 20.0) + -- 5.0 points for .git directory; 5.0 for .githooks or core.hooksPath configuration; + -- 5.0 for commit-msg with RFC 2822 trailer validation; 5.0 for pre-commit and .gitmessage. + gitScore = (if hasGitRepo gitHarness then 5.0 else 0.0) + + (if hasHooksDir gitHarness || isJust (hooksPathConfig gitHarness) then 5.0 else 0.0) + + (if hasCommitMsgHook gitHarness && hasCommitMsgAttributionCheck gitHarness then 5.0 else 0.0) + + (if hasPreCommitHook gitHarness && hasGitMessageTemplate gitHarness then 5.0 else 0.0) + + -- Pillar 5: Five-Gate Physical Verification Readiness (max 15.0) + -- 5.0 points for turnkey verify script; 3.0 for Tagref; 3.0 for Linkcheck; 2.0 for CLOC; 2.0 for linters. + vScore = (if hasVerifyScript verifHarness then 5.0 else 0.0) + + (if hasTagrefConfig verifHarness || hasTagrefHarness verifHarness then 3.0 else 0.0) + + (if hasLinkcheckHarness verifHarness then 3.0 else 0.0) + + (if hasClocHarness verifHarness then 2.0 else 0.0) + + (if hasHlintConfig verifHarness || hasFourmoluConfig verifHarness then 2.0 else 0.0) + + -- Aggregate sum clamped to [0.0, 100.0] and rounded to one decimal place + total = langScore + testScore + docScore + gitScore + vScore + in fromIntegral (round (total * 10 :: Double) :: Int) / 10.0 + +-- | Generates an ordered, actionable remediation plan addressing diagnosed gaps. +-- +-- Synthesizes actionable remediation steps sequenced logically: +-- 1. Git governance and hook installation. +-- 2. Physical verification runner synthesis. +-- 3. Critical and recommended documentation scaffolding. +-- 4. Test infrastructure bootstrapping. +-- 5. Multi-package migration recommendations. +computeRemediationPlan + :: Text + -> WorkspaceLayout + -> TestInfrastructure + -> [DocGap] + -> GitGovernanceStatus + -> VerificationHarnessStatus + -> [Text] +computeRemediationPlan proj layout tests docs gitHarness verifHarness = + concat + [ planGit + , planVerify + , planDocs + , planTests + , planLayout + ] + where + planGit + | not (hasGitRepo gitHarness) = + [ "Initialize Git repository ('git init') and activate canonical hooks." ] + | not (hasHooksDir gitHarness) || not (hasCommitMsgHook gitHarness) = + [ "Install .githooks with Sarutahiko RFC 2822 commit trailer attribution enforcement." ] + | not (hasGitMessageTemplate gitHarness) = + [ "Install .gitmessage commit template and configure 'git config commit.template .gitmessage'." ] + | otherwise = [] + + planVerify + | not (hasVerifyScript verifHarness) = + [ "Generate turnkey 5-gate physical verification harness ('bin/" <> proj <> "-verify')." ] + | not (hasTagrefHarness verifHarness) = + [ "Install Tagref cross-reference configuration and verification runner ('bin/" <> proj <> "-tagref')." ] + | not (hasLinkcheckHarness verifHarness) = + [ "Install Markdown link and anchor integrity runner ('bin/" <> proj <> "-linkcheck')." ] + | not (hasClocHarness verifHarness) = + [ "Install CLOC comment density audit harness ('bin/" <> proj <> "-cloc')." ] + | otherwise = [] + + planDocs = + let missingCrit = filter (\d -> not (docPresent d) && docSeverity d == SeverityCritical) docs + missingRec = filter (\d -> not (docPresent d) && docSeverity d == SeverityRecommended) docs + critItems = map (\d -> "Scaffold mandatory document: " <> T.pack (docPath d)) missingCrit + recItems = map (\d -> "Scaffold recommended document: " <> T.pack (docPath d)) missingRec + in critItems ++ recItems + + planTests + | not (hasTests tests) = + [ "Establish baseline test suite in test/ or packages/*/test." ] + | otherwise = [] + + planLayout + | layout == LayoutSinglePackage = + [ "Consider migrating from single-package layout to multi-package hierarchy (packages/" <> proj <> "/)." ] + | otherwise = [] + +-- | Heuristically infers the canonical project name from directory name or build manifests. +-- +-- Inspects root @*.cabal@ manifest filename if present. If absent (e.g. multi-package workspace), +-- falls back to the normalized basename of the workspace root directory. +inferProjectName :: FilePath -> [BuildSystem] -> [FilePath] -> Text +inferProjectName root _builds paths = + let rootCabalFiles = filter isRootCabal paths + in case rootCabalFiles of + (cf:_) -> + let base = takeFileName cf + name = take (length base - 6) base + in if null name then fallback else T.pack name + [] -> fallback + where + isRootCabal p = + let d = takeDirectory p + in (d == "." || d == "") && ".cabal" `isSuffixOf` p + + fallback = + let base = takeFileName (dropTrailingPathSeparator root) + in if null base || base == "." then "project" else T.pack base + +-------------------------------------------------------------------------------- +-- 9. Top-Level Scanner Orchestration +-------------------------------------------------------------------------------- + +-- | Analyzes an arbitrary target repository checkout, evaluating all six diagnostic +-- dimensions and synthesizing a comprehensive 'DiagnosticReport'. +-- +-- This operation is strictly read-only and non-destructive: +-- * Zero filesystem mutations occur on the target directory. +-- * Traversal prunes ignored build artifacts (@isIgnoredDirectory@). +-- * Recovers gracefully from permission issues or broken links. +-- +-- === Examples +-- +-- >>> report <- scanRepository "." +-- >>> diagProjectName report +-- "gachi" +scanRepository :: FilePath -> IO DiagnosticReport +scanRepository rawRoot = do + absRoot <- makeAbsolute rawRoot + paths <- listRepositoryFiles absRoot + let langs = detectLanguages paths + primaryLang = case langs of + (top:_) -> Just (langType top) + [] -> Nothing + (builds, layout) = detectBuildSystems absRoot paths + projName = inferProjectName absRoot builds paths + + testInfra <- detectTestInfrastructure absRoot paths builds + let docGaps = detectDocumentationGaps absRoot paths + (reqDocs, _) = partition (\d -> docSeverity d /= SeverityOptional) docGaps + presentReq = length (filter docPresent reqDocs) + totalReq = max 1 (length reqDocs) + docPct = fromIntegral (round ((fromIntegral presentReq / fromIntegral totalReq * 100.0) * 10 :: Double) :: Int) / 10.0 + + gitGov <- detectGitGovernance absRoot + verifHarn <- detectVerificationHarnesses absRoot paths + + let score = computeRetrofitScore langs builds testInfra docGaps gitGov verifHarn + remediation = computeRemediationPlan projName layout testInfra docGaps gitGov verifHarn + + -- Discover package names + let pkgNames = discoverPackages paths + + pure DiagnosticReport + { diagTargetDir = rawRoot + , diagProjectName = projName + , diagPrimaryLanguage = primaryLang + , diagLanguages = langs + , diagBuildSystems = builds + , diagLayout = layout + , diagDiscoveredPackages = pkgNames + , diagTestInfra = testInfra + , diagDocGaps = docGaps + , diagDocCompliancePct = docPct + , diagGitGovernance = gitGov + , diagVerificationHarness = verifHarn + , diagRetrofitScore = score + , diagRemediationPlan = remediation + } + where + discoverPackages ps = + let cabalFiles = filter (\p -> ".cabal" `isSuffixOf` p) ps + names = map (\p -> let f = takeFileName p in T.pack (take (length f - 6) f)) cabalFiles + in nub names diff --git a/src/Gachi/Retrofit/Overlay.hs b/src/Gachi/Retrofit/Overlay.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Retrofit/Overlay.hs @@ -0,0 +1,747 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Module: Gachi.Retrofit.Overlay +-- Description: Non-destructive skeleton overlay engine and asset synthesis +-- +-- This module implements the non-destructive skeleton overlay engine for Gachi +-- (Milestone 4.2, Phase 4 per ~/src/PLAN.md §1.A). It synthesizes missing +-- documentation hierarchies, AI agent advisories, Git governance hooks, and turnkey +-- physical verification harnesses over arbitrary pre-existing or legacy repositories. +-- +-- = Architectural Context & Invariants +-- +-- Architectural Invariant: Note [Non-Destructive Skeleton Overlay] [ref:note-nondestructive-retrofit] +-- +-- In accordance with Note [Non-Destructive Skeleton Overlay] [ref:note-nondestructive-retrofit] +-- and Note [Ecosystem Standardization Invariants] [ref:note-ecosystem-standardization], +-- retrofitting operations adopt foreign, legacy, or single-package repositories into the +-- canonical multi-package ecosystem hierarchy while observing four strict operational invariants: +-- +-- 1. __Preservation of Domain Logic:__ +-- The overlay engine must never overwrite, mutate, or delete existing source code +-- files in @src/@, @app/@, @lib/@, @test/@, or domain-specific subdirectories. +-- Pre-existing files on disk are strictly preserved and classified as 'ActionPreserve'. +-- +-- 2. __Pure Plan Construction:__ +-- The overlay computation phase ('computeOverlayPlan') is completely decoupled from +-- filesystem side effects. It produces an explicit, inspectable 'OverlayPlan' +-- categorizing every canonical asset into 'ActionCreate' or 'ActionPreserve'. +-- +-- 3. __Turnkey Verification Harness Delivery:__ +-- The synthesized overlay provisions turnkey verification scripts (@bin/-verify@, +-- @bin/-tagref@, @bin/-linkcheck@, @bin/-cloc@, @bin/generate-tags@) +-- with POSIX executable permissions (@+x@), empowering developers to immediately run all +-- five physical verification gates. +-- +-- 4. __Git Governance Realization:__ +-- Configures local Git repository governance (@core.hooksPath = .githooks@ and +-- @commit.template = .gitmessage@), activating the Sarutahiko RFC 2822 @Assisted-by:@ +-- commit trailer validation hook and pre-commit checks without touching commit history. +-- +-- = When to Use This Module +-- +-- Import this module when planning or applying non-destructive ecosystem overlays +-- in the @gachi retrofit@ subcommand or programmatically migrating legacy checkouts. +-- +-- = Worked Example +-- +-- >>> import Gachi.Retrofit.Diagnostic (scanRepository) +-- >>> import Gachi.Retrofit.Overlay +-- >>> report <- scanRepository "/path/to/legacy/repo" +-- >>> plan <- computeOverlayPlan "/path/to/legacy/repo" report +-- >>> planCreatedCount plan >= 0 +-- True +-- >>> res <- executeOverlayPlan plan +-- >>> resultSuccess res +-- True +module Gachi.Retrofit.Overlay + ( -- * Core Overlay Types + OverlayActionType(..) + , OverlayCategory(..) + , OverlayAction(..) + , GitGovernanceAction(..) + , OverlayPlan(..) + , OverlayResult(..) + + -- * Planning and Synthesis + , computeOverlayPlan + , synthesizeOverlayCandidates + , detectGitAuthor + + -- * Execution Engine + , executeOverlayPlan + , overlayRepository + + -- * Pretty-Printing & Dashboards + , formatOverlayPlan + , formatOverlayPlanMarkdown + , formatOverlayResult + , overlayCategoryName + ) where + +import Control.Exception (SomeException, catch) +import Control.Monad (forM, when) +import Data.Either (lefts, rights) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import GHC.Generics (Generic) +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getPermissions + , listDirectory + , setOwnerExecutable + , setPermissions + ) +import System.Exit (ExitCode(..)) +import System.FilePath (takeDirectory, ()) +import System.Process (readProcessWithExitCode) + +import Gachi.Retrofit.Types + ( DiagnosticReport(..) + , GitGovernanceStatus(..) + , WorkspaceLayout(..) + ) +import Gachi.Scaffold.Templates + ( agentsTemplate + , cabalProjectLocalTemplate + , claudeTemplate + , commitMsgHookTemplate + , docsCommitAttributionTemplate + , docsIndexTemplate + , docsMaintainerGuideTemplate + , docsNewbieGuideTemplate + , docsStrategyTemplate + , docsTutorialTemplate + , generateTagsTemplate + , gitmessageTemplate + , hlintTemplate + , linkcheckScriptTemplate + , planTemplate + , preCommitHookTemplate + , readmeTemplate + , ruleCodeNavigationTemplate + , ruleCommitAttributionTemplate + , ruleCompilerVerificationTemplate + , ruleDocPrecedenceTemplate + , stateTemplate + , tagrefConfigTemplate + , tagrefScriptTemplate + ) +import Gachi.Schema.Project + ( Author(..) + , Project(..) + , defaultProject + , projectName + ) +import Gachi.Sync.CI + ( defaultGitHubSpec + , defaultGitLabSpec + , generateGitHubWorkflow + , generateGitLabWorkflow + ) +import Gachi.Sync.Catalog + ( fourmoluTemplate + ) + +-------------------------------------------------------------------------------- +-- 1. Core Data Types +-------------------------------------------------------------------------------- + +-- | Distinguishes whether an overlay candidate should be created anew or preserved. +data OverlayActionType + = ActionCreate + -- ^ The candidate asset is missing from the destination and will be created. + | ActionPreserve + -- ^ The destination already contains this file; it is preserved completely untouched. + deriving stock (Eq, Show, Generic) + +-- | Functional category grouping standardized ecosystem assets. +data OverlayCategory + = CategoryDocumentation + -- ^ Operational and strategic documentation (DOC_STRATEGY.md, INDEX.md, PLAN.md). + | CategoryAgentAdvisory + -- ^ AI agent advisory context and modular rules (AGENTS.md, CLAUDE.md, .agents/rules/). + | CategoryGitGovernance + -- ^ Git hooks and commit message templates (.githooks/, .gitmessage). + | CategoryVerification + -- ^ Turnkey 5-gate physical verification scripts and harnesses (bin/*-verify, Tagref). + | CategoryToolchain + -- ^ Static linters, formatters, and compiler options (.hlint.yaml, fourmolu.yaml). + | CategoryCIWorkflow + -- ^ Multi-forge CI pipeline configurations (.github/workflows/, .gitlab-ci.yml). + deriving stock (Eq, Show, Generic) + +-- | Human-readable title for an 'OverlayCategory'. +overlayCategoryName :: OverlayCategory -> Text +overlayCategoryName = \case + CategoryDocumentation -> "Documentation Corpus" + CategoryAgentAdvisory -> "Agent Advisory Layer" + CategoryGitGovernance -> "Git Governance & Hooks" + CategoryVerification -> "Physical Verification Harnesses" + CategoryToolchain -> "Toolchain & Linter Configurations" + CategoryCIWorkflow -> "Forge-Tiered CI Workflows" + +-- | Represents a planned file-level action in the non-destructive overlay. +data OverlayAction = OverlayAction + { actionType :: !OverlayActionType + -- ^ Creation policy ('ActionCreate' or 'ActionPreserve'). + , actionPath :: !FilePath + -- ^ Relative file path from repository root (e.g. @"docs/INDEX.md"@). + , actionContent :: !Text + -- ^ Textual content to be written if 'actionType' is 'ActionCreate'. + , actionExecutable :: !Bool + -- ^ Whether POSIX owner executable bit (+x) must be set upon creation. + , actionCategory :: !OverlayCategory + -- ^ Functional category grouping. + , actionDescription :: !Text + -- ^ Brief human-readable description of this asset's purpose. + } deriving stock (Eq, Show, Generic) + +-- | Represents a Git governance configuration mutation. +data GitGovernanceAction + = GitInitRepo + -- ^ Invoke @git init@ because no @.git@ directory exists. + | GitSetConfig !Text !Text + -- ^ Invoke @git config key val@ to pin canonical hook paths or commit templates. + deriving stock (Eq, Show, Generic) + +-- | Complete, referentially transparent plan detailing all actions to be performed +-- during codebase retrofitting. +data OverlayPlan = OverlayPlan + { planTargetDir :: !FilePath + -- ^ Target codebase checkout directory. + , planProjectName :: !Text + -- ^ Detected or inferred project identifier slug. + , planActions :: ![OverlayAction] + -- ^ Ordered list of file-level creation or preservation actions. + , planGitActions :: ![GitGovernanceAction] + -- ^ Ordered list of Git governance configurations. + , planCreatedCount :: !Int + -- ^ Total count of missing files scheduled for creation. + , planPreservedCount :: !Int + -- ^ Total count of pre-existing files preserved untouched. + } deriving stock (Eq, Show, Generic) + +-- | Concrete outcome and statistics from executing an 'OverlayPlan' on disk. +data OverlayResult = OverlayResult + { resultTargetDir :: !FilePath + -- ^ Destination repository directory. + , resultProjectName :: !Text + -- ^ Project identifier slug. + , resultCreatedFiles :: ![FilePath] + -- ^ Relative paths of files successfully materialized on disk. + , resultPreservedFiles :: ![FilePath] + -- ^ Relative paths of files preserved untouched. + , resultGitActions :: ![Text] + -- ^ Descriptions of Git governance actions successfully executed. + , resultSuccess :: !Bool + -- ^ Overall operational success indicator. + } deriving stock (Eq, Show, Generic) + +-------------------------------------------------------------------------------- +-- 2. Ambient Git Author Detection +-------------------------------------------------------------------------------- + +-- | Queries ambient Git configuration (@git config --get user.name@ and +-- @git config --get user.email@) to personalize synthesized documentation and +-- package metadata. +-- +-- Falls back gracefully to canonical ecosystem author values if Git is unconfigured +-- or inaccessible in headless environments. +detectGitAuthor :: IO Author +detectGitAuthor = do + (cName, oName, _) <- readProcessWithExitCode "git" ["config", "--get", "user.name"] "" + `catch` (\(_ :: SomeException) -> pure (ExitFailure 1, "", "")) + (cEmail, oEmail, _) <- readProcessWithExitCode "git" ["config", "--get", "user.email"] "" + `catch` (\(_ :: SomeException) -> pure (ExitFailure 1, "", "")) + let nameTrimmed = T.strip (T.pack oName) + emailTrimmed = T.strip (T.pack oEmail) + authName = if cName == ExitSuccess && not (T.null nameTrimmed) + then nameTrimmed + else "Nadia Yvette Chambers" + authEmail = if cEmail == ExitSuccess && not (T.null emailTrimmed) + then emailTrimmed + else "nadia.yvette.chambers@ik.me" + pure Author { name = authName, email = authEmail } + +-------------------------------------------------------------------------------- +-- 3. Pure Candidate Synthesis +-------------------------------------------------------------------------------- + +-- | Synthesizes all canonical candidate assets that comprise the standardized +-- ecosystem skeleton overlay for a project. +-- +-- Every candidate is tagged with its relative path, content, executable requirement, +-- category, and description. Does not inspect ambient filesystem state. +synthesizeOverlayCandidates :: Project -> WorkspaceLayout -> [OverlayAction] +synthesizeOverlayCandidates proj layout = + let pName = projectName proj + -- 1. Documentation Corpus + docs = + [ OverlayAction ActionCreate "README.md" (readmeTemplate proj) False CategoryDocumentation "Arrivals & orientation overview" + , OverlayAction ActionCreate "PLAN.md" (planTemplate proj) False CategoryDocumentation "Strategic operational roadmap" + , OverlayAction ActionCreate "STATE.md" (stateTemplate proj) False CategoryDocumentation "Active operational frontier and state" + , OverlayAction ActionCreate "docs/INDEX.md" (docsIndexTemplate proj) False CategoryDocumentation "Complete documentation corpus index" + , OverlayAction ActionCreate "docs/TUTORIAL.md" (docsTutorialTemplate proj) False CategoryDocumentation "Step-by-step tutorial track" + , OverlayAction ActionCreate "docs/NEWBIE_GUIDE.md" (docsNewbieGuideTemplate proj) False CategoryDocumentation "Onboarding guide for new contributors" + , OverlayAction ActionCreate "docs/MAINTAINER_GUIDE.md" (docsMaintainerGuideTemplate proj) False CategoryDocumentation "Operational guide for maintainers" + , OverlayAction ActionCreate "docs/notes/DOC_STRATEGY.md" (docsStrategyTemplate proj) False CategoryDocumentation "Canonical documentation policy and taxonomy" + , OverlayAction ActionCreate "docs/notes/COMMIT_ATTRIBUTION.md" (docsCommitAttributionTemplate proj) False CategoryDocumentation "RFC 2822 commit trailer attribution specification" + ] + + -- 2. Agent Advisory Layer + advisories = + [ OverlayAction ActionCreate "AGENTS.md" (agentsTemplate proj) False CategoryAgentAdvisory "Primary agent advisory pointer file" + , OverlayAction ActionCreate "CLAUDE.md" (claudeTemplate proj) False CategoryAgentAdvisory "Compatibility symlink and instructions" + , OverlayAction ActionCreate ".agents/rules/commit-attribution.md" ruleCommitAttributionTemplate False CategoryAgentAdvisory "Rule: Commit trailer attribution" + , OverlayAction ActionCreate ".agents/rules/code-navigation.md" ruleCodeNavigationTemplate False CategoryAgentAdvisory "Rule: Token-efficient code navigation" + , OverlayAction ActionCreate ".agents/rules/compiler-verification.md" ruleCompilerVerificationTemplate False CategoryAgentAdvisory "Rule: Zero-log compiler verification" + , OverlayAction ActionCreate ".agents/rules/documentation-precedence.md" ruleDocPrecedenceTemplate False CategoryAgentAdvisory "Rule: Documentation precedence" + ] + + -- 3. Git Governance & Hooks + governance = + [ OverlayAction ActionCreate ".gitmessage" gitmessageTemplate False CategoryGitGovernance "Commit message template with Assisted-by: trailers" + , OverlayAction ActionCreate ".githooks/commit-msg" commitMsgHookTemplate True CategoryGitGovernance "Commit message hook validating RFC 2822 trailers" + , OverlayAction ActionCreate ".githooks/pre-commit" (preCommitHookTemplate proj) True CategoryGitGovernance "Pre-commit hook checking Tagref and link integrity" + ] + + -- 4. Verification Harnesses + verification = + [ OverlayAction ActionCreate ("bin/" <> T.unpack pName <> "-verify") (customVerifyScript pName layout) True CategoryVerification "Turnkey 5-gate physical verification runner" + , OverlayAction ActionCreate ("bin/" <> T.unpack pName <> "-tagref") (tagrefScriptTemplate proj) True CategoryVerification "Tagref cross-reference checking harness" + , OverlayAction ActionCreate ("bin/" <> T.unpack pName <> "-linkcheck") (linkcheckScriptTemplate proj) True CategoryVerification "Markdown link and anchor verification harness" + , OverlayAction ActionCreate ("bin/" <> T.unpack pName <> "-cloc") (customClocScript pName layout) True CategoryVerification "CLOC comment density auditing harness" + , OverlayAction ActionCreate "bin/generate-tags" generateTagsTemplate True CategoryVerification "Fast ctags/hasktags symbol indexing script" + , OverlayAction ActionCreate "tagref.yml" (tagrefConfigTemplate proj) False CategoryVerification "Tagref cross-reference configuration" + ] + + -- 5. Toolchain Configurations + toolchain = + [ OverlayAction ActionCreate ".hlint.yaml" hlintTemplate False CategoryToolchain "Zero-hint HLint static analysis configuration" + , OverlayAction ActionCreate "fourmolu.yaml" fourmoluTemplate False CategoryToolchain "Deterministic fourmolu code formatting profile" + , OverlayAction ActionCreate "cabal.project.local.example" cabalProjectLocalTemplate False CategoryToolchain "Local developer Cabal project configuration" + ] + + -- 6. CI Workflows + ciWorkflows = + [ OverlayAction ActionCreate ".github/workflows/ci.yml" (generateGitHubWorkflow defaultGitHubSpec proj) False CategoryCIWorkflow "High-resource GitHub Actions CI workflow" + , OverlayAction ActionCreate ".gitlab-ci.yml" (generateGitLabWorkflow defaultGitLabSpec proj) False CategoryCIWorkflow "Lightweight community GitLab CI pipeline" + ] + + in docs ++ advisories ++ governance ++ verification ++ toolchain ++ ciWorkflows + +-- | Constructs a customized @bin/-verify@ script tailored to both +-- multi-package (@packages/*/src@) and single-package (@src/@) workspaces. +customVerifyScript :: Text -> WorkspaceLayout -> Text +customVerifyScript pName _ = + T.unlines + [ "#!/usr/bin/env bash" + , "# bin/" <> pName <> "-verify — Physical verification runner for " <> pName + , "set -euo pipefail" + , "" + , "SCRIPT_DIR=\"$(cd \"$(dirname \"${BASH_SOURCE[0]}\")\" && pwd)\"" + , "REPO_ROOT=\"$(cd \"${SCRIPT_DIR}/..\" && pwd)\"" + , "" + , "verify_hlint() {" + , " echo \"=== [1/5] HLint Static Analysis Gate ===\"" + , " local hlint_cmd=\"\"" + , " if [[ -x \"${HOME}/.ghcup/bin/hlint\" ]]; then" + , " hlint_cmd=\"${HOME}/.ghcup/bin/hlint\"" + , " elif [[ -x \"${HOME}/.local/bin/hlint\" ]]; then" + , " hlint_cmd=\"${HOME}/.local/bin/hlint\"" + , " elif command -v hlint >/dev/null 2>&1; then" + , " hlint_cmd=\"$(command -v hlint)\"" + , " fi" + , "" + , " if [[ -n \"${hlint_cmd}\" ]]; then" + , " local target_paths=()" + , " if compgen -G \"${REPO_ROOT}/packages/*/src\" > /dev/null; then" + , " target_paths+=(\"${REPO_ROOT}\"/packages/*/src)" + , " fi" + , " if [[ -d \"${REPO_ROOT}/src\" ]]; then" + , " target_paths+=(\"${REPO_ROOT}/src\")" + , " fi" + , " if [[ ${#target_paths[@]} -gt 0 ]]; then" + , " \"${hlint_cmd}\" \"${target_paths[@]}\" >/dev/null" + , " echo \" [+] Clean HLint run: 0 hints.\"" + , " else" + , " echo \" [SKIP] No Haskell src directories found.\"" + , " fi" + , " else" + , " echo \" [SKIP] hlint binary not found.\"" + , " fi" + , "}" + , "" + , "verify_tests() {" + , " echo \"=== [2/5] Full Cabal Test Suite ===\"" + , " if [[ -f \"${REPO_ROOT}/cabal.project\" ]] || compgen -G \"${REPO_ROOT}/*.cabal\" > /dev/null; then" + , " (cd \"${REPO_ROOT}\" && cabal test all --test-show-details=streaming)" + , " echo \" [+] All test suite assertions PASSED.\"" + , " else" + , " echo \" [SKIP] No Cabal build manifests found.\"" + , " fi" + , "}" + , "" + , "verify_tagref() {" + , " echo \"=== [3/5] Tagref Cross-Reference Gate ===\"" + , " if [[ -x \"${REPO_ROOT}/bin/" <> pName <> "-tagref\" ]]; then" + , " local tagref_out" + , " tagref_out=\"$(\"${REPO_ROOT}/bin/" <> pName <> "-tagref\")\"" + , " echo \" [+] Tagref verified: ${tagref_out}\"" + , " elif command -v tagref >/dev/null 2>&1; then" + , " (cd \"${REPO_ROOT}\" && tagref >/dev/null)" + , " echo \" [+] Tagref verified: 0 dangling references, 0 duplicate tags.\"" + , " else" + , " echo \" [SKIP] tagref binary not found.\"" + , " fi" + , "}" + , "" + , "verify_linkcheck() {" + , " echo \"=== [4/5] Markdown Link & Anchor Integrity Gate ===" + , " if [[ -x \"${REPO_ROOT}/bin/" <> pName <> "-linkcheck\" ]]; then" + , " local linkcheck_out" + , " linkcheck_out=\"$(\"${REPO_ROOT}/bin/" <> pName <> "-linkcheck\" --quiet)\"" + , " echo \" [+] Markdown links verified: ${linkcheck_out}\"" + , " else" + , " echo \" [SKIP] bin/" <> pName <> "-linkcheck not found or not executable.\"" + , " fi" + , "}" + , "" + , "verify_cloc() {" + , " echo \"=== [5/5] CLOC Comment Density Gate ===\"" + , " if [[ -x \"${REPO_ROOT}/bin/" <> pName <> "-cloc\" ]]; then" + , " local cloc_out" + , " cloc_out=\"$(\"${REPO_ROOT}/bin/" <> pName <> "-cloc\" --quiet --check)\"" + , " echo \" [+] Comment density verified: ${cloc_out}\"" + , " else" + , " echo \" [SKIP] bin/" <> pName <> "-cloc not found or not executable.\"" + , " fi" + , "}" + , "" + , "verify_hlint" + , "verify_tests" + , "verify_tagref" + , "verify_linkcheck" + , "verify_cloc" + , "" + , "echo \"=== All 5 Physical Verification Checks PASSED ===\"" + ] + +-- | Constructs a customized @bin/-cloc@ script capable of evaluating +-- both multi-package (@packages/*/src@) and single-package (@src/@) layouts. +customClocScript :: Text -> WorkspaceLayout -> Text +customClocScript pName _ = + T.unlines + [ "#!/usr/bin/env python3" + , "\"\"\"" + , "bin/" <> pName <> "-cloc — Comment Density Audit Harness for " <> pName + , "\"\"\"" + , "import sys, os, glob, argparse" + , "" + , "REPO_ROOT = os.path.abspath(os.path.join(os.path.dirname(__file__), \"..\"))" + , "" + , "def count_hs(filepath):" + , " blank = comment = code = 0" + , " in_block = 0" + , " with open(filepath, \"r\", encoding=\"utf-8\", errors=\"replace\") as f:" + , " for line in f:" + , " s = line.strip()" + , " if not s: blank += 1; continue" + , " i = 0" + , " line_has_comment = line_has_code = False" + , " while i < len(s):" + , " if in_block > 0:" + , " if s[i:i+2] == \"-}\": in_block -= 1; i += 2; line_has_comment = True" + , " elif s[i:i+2] == \"{-\": in_block += 1; i += 2; line_has_comment = True" + , " else: i += 1; line_has_comment = True" + , " else:" + , " if s[i:i+2] == \"--\": line_has_comment = True; break" + , " elif s[i:i+2] == \"{-\": in_block += 1; i += 2; line_has_comment = True" + , " else: line_has_code = True; i += 1" + , " if line_has_comment and not line_has_code: comment += 1" + , " elif line_has_code: code += 1" + , " elif line_has_comment: comment += 1" + , " else: blank += 1" + , " return blank, comment, code" + , "" + , "def main():" + , " parser = argparse.ArgumentParser()" + , " parser.add_argument(\"--quiet\", \"-q\", action=\"store_true\")" + , " parser.add_argument(\"--check\", action=\"store_true\", default=True)" + , " args = parser.parse_args()" + , " src_files = glob.glob(os.path.join(REPO_ROOT, \"packages\", \"*\", \"src\", \"**\", \"*.hs\"), recursive=True)" + , " src_files += glob.glob(os.path.join(REPO_ROOT, \"src\", \"**\", \"*.hs\"), recursive=True)" + , " src_files = sorted(list(set(src_files)))" + , " tot_comment = tot_code = 0" + , " for f in src_files:" + , " _, com, cod = count_hs(f)" + , " tot_comment += com; tot_code += cod" + , " tot_all = tot_comment + tot_code" + , " density = (tot_comment / tot_all * 100.0) if tot_all > 0 else 100.0" + , " if args.check and density < 25.0:" + , " print(f\"Comment density gate FAILED: {density:.1f}% < 25.0% threshold\", file=sys.stderr)" + , " sys.exit(1)" + , " print(f\"{density:.1f}% ({tot_comment} comments / {tot_code} code lines in src/; target: 50.0%+)\")" + , "" + , "if __name__ == '__main__': main()" + ] + +-------------------------------------------------------------------------------- +-- 4. Overlay Plan Computation +-------------------------------------------------------------------------------- + +-- | Recursively collects all existing relative file paths in a directory. +collectExistingFiles :: FilePath -> IO [FilePath] +collectExistingFiles root = do + exists <- doesDirectoryExist root + if not exists + then pure [] + else go root "" + where + go baseDir relPrefix = do + entries <- listDirectory (baseDir relPrefix) + `catch` (\(_ :: SomeException) -> pure []) + fpaths <- forM entries $ \e -> do + let rel = if null relPrefix then e else relPrefix e + full = baseDir rel + isDir <- doesDirectoryExist full + if isDir + then if e `elem` [".git", "dist-newstyle", ".stack-work", "target", "node_modules"] + then pure [] + else go baseDir rel + else pure [rel] + pure (concat fpaths) + +-- | Computes the non-destructive overlay plan for a target repository. +-- +-- Analyzes pre-existing files on disk and compares them against the canonical candidate +-- assets. Observes Note [Non-Destructive Skeleton Overlay] [ref:note-nondestructive-retrofit]: +-- any file that already exists is strictly preserved and never scheduled for overwrite. +computeOverlayPlan :: FilePath -> DiagnosticReport -> IO OverlayPlan +computeOverlayPlan targetDir report = do + absTarget <- canonicalizePath targetDir + existingFiles <- collectExistingFiles absTarget + auth <- detectGitAuthor + + let pName = diagProjectName report + layout = diagLayout report + proj = defaultProject pName auth + candidates = synthesizeOverlayCandidates proj layout + + -- Partition candidates into Create vs Preserve based on disk presence + actions <- forM candidates $ \cand -> do + let dest = absTarget actionPath cand + existsOnDisk <- doesFileExist dest + let isExisting = existsOnDisk || actionPath cand `elem` existingFiles + if isExisting + then pure cand + { actionType = ActionPreserve + , actionContent = "" + , actionDescription = "Pre-existing file preserved intact (non-destructive policy)" + } + else pure cand + { actionType = ActionCreate + } + + -- Compute Git governance requirements + let gitStatus = diagGitGovernance report + gitActions = + [ GitInitRepo | not (hasGitRepo gitStatus) ] + ++ [ GitSetConfig "core.hooksPath" ".githooks" + | hooksPathConfig gitStatus /= Just ".githooks" + ] + ++ [ GitSetConfig "commit.template" ".gitmessage" + | gitMessageConfig gitStatus /= Just ".gitmessage" + ] + + let createdCount = length [() | a <- actions, actionType a == ActionCreate] + preservedCount = length [() | a <- actions, actionType a == ActionPreserve] + + pure OverlayPlan + { planTargetDir = targetDir + , planProjectName = pName + , planActions = actions + , planGitActions = gitActions + , planCreatedCount = createdCount + , planPreservedCount = preservedCount + } + +-------------------------------------------------------------------------------- +-- 5. Overlay Plan Execution +-------------------------------------------------------------------------------- + +-- | Executes an 'OverlayPlan' on disk, writing missing standardized assets, setting +-- executable bits, and configuring Git governance. +-- +-- Strictly adheres to Note [Non-Destructive Skeleton Overlay] [ref:note-nondestructive-retrofit]: +-- files marked 'ActionPreserve' are never touched. +executeOverlayPlan :: OverlayPlan -> IO OverlayResult +executeOverlayPlan plan = do + absTarget <- canonicalizePath (planTargetDir plan) + createDirectoryIfMissing True absTarget + + -- 1. Materialize Missing Files + createdResults <- forM (planActions plan) $ \action -> do + case actionType action of + ActionPreserve -> pure (Left (actionPath action)) + ActionCreate -> do + let dest = absTarget actionPath action + createDirectoryIfMissing True (takeDirectory dest) + TIO.writeFile dest (actionContent action) + when (actionExecutable action) $ do + p <- getPermissions dest + setPermissions dest (setOwnerExecutable True p) + pure (Right (actionPath action)) + + let createdFiles = rights createdResults + preservedFiles = lefts createdResults + + -- 2. Execute Git Governance Actions + executedGitActions <- forM (planGitActions plan) $ \case + GitInitRepo -> do + (cInit, _, _) <- readProcessWithExitCode "git" ["init", absTarget] "" + `catch` (\(_ :: SomeException) -> pure (ExitFailure 1, "", "")) + if cInit == ExitSuccess + then pure (Just "Initialized new Git repository (.git)") + else pure Nothing + + GitSetConfig key val -> do + (cConf, _, _) <- readProcessWithExitCode "git" ["-C", absTarget, "config", T.unpack key, T.unpack val] "" + `catch` (\(_ :: SomeException) -> pure (ExitFailure 1, "", "")) + if cConf == ExitSuccess + then pure (Just ("Configured git " <> key <> " = " <> val)) + else pure Nothing + + let validGitActions = catMaybes executedGitActions + + pure OverlayResult + { resultTargetDir = planTargetDir plan + , resultProjectName = planProjectName plan + , resultCreatedFiles = createdFiles + , resultPreservedFiles = preservedFiles + , resultGitActions = validGitActions + , resultSuccess = True + } + +-- | Turnkey convenience runner: scans repository, computes overlay plan, and applies +-- the non-destructive overlay when not in dry-run mode. +overlayRepository + :: FilePath + -> Bool + -> DiagnosticReport + -> IO (OverlayPlan, Maybe OverlayResult) +overlayRepository targetDir isDryRun report = do + plan <- computeOverlayPlan targetDir report + if isDryRun + then pure (plan, Nothing) + else do + res <- executeOverlayPlan plan + pure (plan, Just res) + +-------------------------------------------------------------------------------- +-- 6. Formatting & Pretty-Printing +-------------------------------------------------------------------------------- + +-- | Formats an 80-column boxed ASCII preview of an 'OverlayPlan'. +formatOverlayPlan :: OverlayPlan -> Text +formatOverlayPlan plan = + let created = [a | a <- planActions plan, actionType a == ActionCreate] + preserved = [a | a <- planActions plan, actionType a == ActionPreserve] + cats = [CategoryDocumentation, CategoryAgentAdvisory, CategoryGitGovernance, CategoryVerification, CategoryToolchain, CategoryCIWorkflow] + in T.unlines $ + [ "================================================================================" + , " Gachi Non-Destructive Skeleton Overlay Plan (~/src/PLAN.md §1.A, Milestone 4.2)" + , "================================================================================" + , " Target Directory: " <> T.pack (planTargetDir plan) + , " Project Identifier: " <> planProjectName plan + , " Proposed Actions: " <> T.pack (show (planCreatedCount plan)) <> " files to CREATE, " + <> T.pack (show (planPreservedCount plan)) <> " files to PRESERVE" + , " Git Governance: " <> T.pack (show (length (planGitActions plan))) <> " configurations planned" + , "--------------------------------------------------------------------------------" + ] + ++ concatMap (formatCategorySection created preserved) cats + ++ + [ "================================================================================" + ] + where + formatCategorySection created preserved cat = + let catCreated = [a | a <- created, actionCategory a == cat] + catPreserved = [a | a <- preserved, actionCategory a == cat] + in if null catCreated && null catPreserved + then [] + else + [ " [" <> overlayCategoryName cat <> "]" + ] + ++ [ " [+] CREATE: " <> T.pack (actionPath a) <> (if actionExecutable a then " (+x)" else "") + | a <- catCreated + ] + ++ [ " [=] PRESERVE: " <> T.pack (actionPath a) <> " (" <> actionDescription a <> ")" + | a <- catPreserved + ] + ++ [ "" ] + +-- | Formats a GitHub-Flavored Markdown summary table of an 'OverlayPlan'. +formatOverlayPlanMarkdown :: OverlayPlan -> Text +formatOverlayPlanMarkdown plan = + T.unlines $ + [ "# Non-Destructive Skeleton Overlay Plan: `" <> planProjectName plan <> "`" + , "" + , "**Target Directory:** `" <> T.pack (planTargetDir plan) <> "` " + , "**Files to Create:** " <> T.pack (show (planCreatedCount plan)) <> " " + , "**Files Preserved Intact:** " <> T.pack (show (planPreservedCount plan)) <> " " + , "**Git Governance Adjustments:** " <> T.pack (show (length (planGitActions plan))) + , "" + , "---" + , "" + , "## Planned Overlay Actions" + , "" + , "| Status | File Path | Executable | Category | Description |" + , "|---|---|---|---|---|" + ] + ++ + [ "| " <> (if actionType a == ActionCreate then "✨ CREATE" else "🛡️ PRESERVE") <> " | `" + <> T.pack (actionPath a) <> "` | " + <> (if actionExecutable a then "`+x`" else "`-`") <> " | " + <> overlayCategoryName (actionCategory a) <> " | " + <> actionDescription a <> " |" + | a <- planActions plan + ] + +-- | Formats an 80-column boxed ASCII report summarizing completed overlay execution. +formatOverlayResult :: OverlayResult -> Text +formatOverlayResult res = + T.unlines $ + [ "================================================================================" + , " Gachi Non-Destructive Overlay Execution Results (Milestone 4.2)" + , "================================================================================" + , " Target Directory: " <> T.pack (resultTargetDir res) + , " Project Identifier: " <> resultProjectName res + , " Files Created: " <> T.pack (show (length (resultCreatedFiles res))) <> " files materialized" + , " Files Preserved: " <> T.pack (show (length (resultPreservedFiles res))) <> " files untouched" + , "--------------------------------------------------------------------------------" + ] + ++ + (if null (resultGitActions res) + then [ " Git Governance: Already fully compliant (.githooks and .gitmessage pinned)" ] + else " Git Governance Updates:" : map (" [+] " <>) (resultGitActions res) + ) + ++ + [ "================================================================================" + , " Overlay successfully applied! Skeletons and verification harnesses installed." + , "" + , " Quick Start Verification:" + , " cd " <> T.pack (resultTargetDir res) + , " ./bin/" <> resultProjectName res <> "-verify" + , "================================================================================" + ] diff --git a/src/Gachi/Retrofit/QualityGate.hs b/src/Gachi/Retrofit/QualityGate.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Retrofit/QualityGate.hs @@ -0,0 +1,913 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Module: Gachi.Retrofit.QualityGate +-- Description: Progressive quality gate evaluation and incremental remediation engine +-- +-- This module implements the progressive quality gate realization engine for Gachi +-- (Milestone 4.3, Phase 4 per ~/src/PLAN.md §1.A). It evaluates arbitrary target +-- repositories through four progressive compliance levels (L0–L3) and generates +-- incremental remediation plans to bring builds under strict compiler discipline. +-- +-- = Architectural Context & Invariants +-- +-- Note [Progressive Quality Gate Realization and Incremental Compliance Levels] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- [tag:note-progressive-quality-gates] +-- The Progressive Quality Gate Realization engine ("Milestone 4.3") bridges the gap +-- between overlay installation ("Milestone 4.2") and empirical validation ("Milestone 4.4") +-- by evaluating a target codebase against four strictly ordered compliance levels: +-- +-- 1. __Level 0 (Foundation):__ +-- Scaffolding, documentation skeletons, and turnkey verification harnesses are physically +-- present and configured. This is the baseline established by Milestones 4.1 and 4.2. +-- Gates: @.git@ initialized, @.githooks/@ present, @bin/-verify@ present (+x), +-- @tagref.yml@ present, @.hlint.yaml@ present, @README.md@ present, @PLAN.md@ present. +-- +-- 2. __Level 1 (Structural Integrity):__ +-- Tagref cross-references certify zero dangling pointers across code, comments, and +-- documentation. Markdown link & anchor integrity holds with zero broken links. The +-- verification harness scripts execute successfully. +-- Gates: @tagref@ exits 0, @linkcheck@ exits 0. +-- +-- 3. __Level 2 (Compiler Discipline):__ +-- The Haskell build compiles cleanly under @-Wall -Wcompat -Wredundant-constraints@ +-- with @cabal build all@ reporting zero warnings. Build artifacts can be produced +-- without any source modifications to domain logic. +-- Gates: @cabal build all 2>&1 | grep -c warning@ == 0. +-- +-- 4. __Level 3 (Static Analysis Purity):__ +-- HLint reports zero hints across all production source files under the project's +-- @.hlint.yaml@ configuration. Comment density meets the 25.0% gate threshold with +-- 50.0%+ target on @src/@. The full test suite passes cleanly. +-- Gates: @hlint@ exits 0, CLOC density >= 25.0%, @cabal test all@ passes. +-- +-- === Monotonic Progression Invariant +-- +-- Quality levels are strictly monotonically ordered: achieving Level N requires that all +-- gates in Levels 0 through N-1 are already satisfied. The evaluator reports the highest +-- achieved level and all failing gates preventing progression: +-- +-- @ +-- L0 ⊂ L1 ⊂ L2 ⊂ L3 +-- @ +-- +-- This ensures incremental tractability: teams address foundation first, then structural +-- integrity, then compiler discipline, then static analysis purity — never skipping steps. +-- +-- Per Note [Non-Destructive Skeleton Overlay] [ref:note-nondestructive-retrofit], all +-- evaluation is strictly observational and non-destructive. Domain logic source files +-- (@src/@, @app/@, @lib/@, @test/@) are never modified by the quality gate evaluator. +-- +-- = Worked Example +-- +-- >>> import Gachi.Retrofit.QualityGate +-- >>> result <- evaluateQualityGates "/path/to/project" +-- >>> qgAchievedLevel result +-- QualityLevel1 +-- >>> length (qgRemediationSteps result) +-- 3 +module Gachi.Retrofit.QualityGate + ( -- * Quality Level Classification + QualityLevel(..) + , qualityLevelName + , qualityLevelOrdinal + + -- * Gate Evaluation Types + , GateCheck(..) + , GateResult(..) + , QualityGateReport(..) + + -- * Remediation Planning + , RemediationStep(..) + , RemediationPriority(..) + , remediationPriorityName + + -- * Pure Gate Construction + , level0Gates + , level1Gates + , level2Gates + , level3Gates + , allLevelGates + + -- * Evaluation Engine + , evaluateQualityGates + , evaluateGateCheck + , computeAchievedLevel + , computeRemediationSteps + + -- * Pretty-Printing & Dashboards + , formatQualityGateReport + , formatQualityGateMarkdown + ) where + +import Control.Exception (SomeException, catch) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import System.Directory + ( doesDirectoryExist + , doesFileExist + , executable + , getPermissions + , listDirectory + , makeAbsolute + ) +import System.Exit (ExitCode(..)) +import System.FilePath (()) +import System.Process + ( CreateProcess(..) + , proc + , readCreateProcessWithExitCode + , readProcessWithExitCode + ) + +import Gachi.Retrofit.Diagnostic (inferProjectName, listRepositoryFiles) + +-------------------------------------------------------------------------------- +-- 1. Quality Level Classification +-------------------------------------------------------------------------------- + +-- | Progressive quality compliance levels, strictly monotonically ordered. +-- +-- Each level subsumes all preceding levels: achieving Level N requires that +-- all gates in Levels 0 through N-1 pass cleanly. +-- +-- === Examples +-- +-- >>> qualityLevelName QualityLevel0 +-- "Level 0: Foundation" +-- >>> qualityLevelOrdinal QualityLevel2 +-- 2 +data QualityLevel + = QualityLevel0 + -- ^ Foundation: scaffolding, documentation skeletons, verification harnesses installed. + | QualityLevel1 + -- ^ Structural Integrity: Tagref zero dangling, Markdown link integrity holds. + | QualityLevel2 + -- ^ Compiler Discipline: clean build under @-Wall -Wcompat -Wredundant-constraints@. + | QualityLevel3 + -- ^ Static Analysis Purity: zero HLint hints, CLOC density, full test suite passing. + deriving stock (Eq, Ord, Show, Generic) + +-- | Human-readable display title for a 'QualityLevel'. +-- +-- === Examples +-- +-- >>> qualityLevelName QualityLevel0 +-- "Level 0: Foundation" +-- >>> qualityLevelName QualityLevel3 +-- "Level 3: Static Analysis Purity" +qualityLevelName :: QualityLevel -> Text +qualityLevelName = \case + QualityLevel0 -> "Level 0: Foundation" + QualityLevel1 -> "Level 1: Structural Integrity" + QualityLevel2 -> "Level 2: Compiler Discipline" + QualityLevel3 -> "Level 3: Static Analysis Purity" + +-- | Ordinal integer value for a 'QualityLevel' (0–3). +-- +-- === Examples +-- +-- >>> qualityLevelOrdinal QualityLevel0 +-- 0 +-- >>> qualityLevelOrdinal QualityLevel3 +-- 3 +qualityLevelOrdinal :: QualityLevel -> Int +qualityLevelOrdinal = \case + QualityLevel0 -> 0 + QualityLevel1 -> 1 + QualityLevel2 -> 2 + QualityLevel3 -> 3 + +-------------------------------------------------------------------------------- +-- 2. Gate Evaluation Types +-------------------------------------------------------------------------------- + +-- | Specification of a single quality gate check, encoding the gate's identity, +-- the quality level it belongs to, and the evaluation strategy. +-- +-- Gate checks are constructed purely and evaluated against the target filesystem +-- by the evaluation engine ('evaluateGateCheck'). +data GateCheck = GateCheck + { gateName :: !Text + -- ^ Human-readable title for this gate (e.g. @"Git Repository Initialized"@). + , gateLevel :: !QualityLevel + -- ^ The quality level this gate contributes to. + , gateDescription :: !Text + -- ^ Brief description of what this gate validates. + , gateEvaluator :: FilePath -> IO Bool + -- ^ The evaluation function: given the repository root, returns 'True' if + -- the gate passes, 'False' otherwise. Must be strictly non-destructive. + } + +-- | Display-friendly instance for 'GateCheck' (omits the evaluator function). +instance Show GateCheck where + show gc = "GateCheck { gateName = " ++ show (gateName gc) + ++ ", gateLevel = " ++ show (gateLevel gc) + ++ " }" + +-- | Structural equality on gate name and level (evaluator cannot be compared). +instance Eq GateCheck where + a == b = gateName a == gateName b && gateLevel a == gateLevel b + +-- | Result of evaluating a single gate check against a target repository. +data GateResult = GateResult + { resultGate :: !GateCheck + -- ^ The evaluated gate specification. + , resultPassed :: !Bool + -- ^ Whether the gate was satisfied. + , resultDetail :: !Text + -- ^ Diagnostic detail or error message explaining the result. + } deriving stock (Show) + +-- | Structural equality on gate identity and pass status. +instance Eq GateResult where + a == b = resultGate a == resultGate b && resultPassed a == resultPassed b + +-- | Comprehensive quality gate evaluation report for a target repository. +-- +-- Produced by 'evaluateQualityGates', containing all gate results, the highest +-- achieved quality level, and prioritized remediation steps for progression. +data QualityGateReport = QualityGateReport + { qgTargetDir :: !FilePath + -- ^ Inspected target directory. + , qgProjectName :: !Text + -- ^ Detected or inferred project identifier. + , qgGateResults :: ![GateResult] + -- ^ Results for all evaluated gates across all levels. + , qgAchievedLevel :: !QualityLevel + -- ^ Highest quality level where all gates passed cleanly. + -- 'QualityLevel0' is the minimum; if Level 0 gates fail, this + -- indicates the foundation is incomplete. + , qgMaxPossibleLevel :: !QualityLevel + -- ^ The highest level that was evaluated (always 'QualityLevel3'). + , qgPassedCount :: !Int + -- ^ Total number of gates that passed across all levels. + , qgFailedCount :: !Int + -- ^ Total number of gates that failed across all levels. + , qgRemediationSteps :: ![RemediationStep] + -- ^ Prioritized incremental remediation actions for advancing to the next level. + } deriving stock (Show, Eq) + +-------------------------------------------------------------------------------- +-- 3. Remediation Planning +-------------------------------------------------------------------------------- + +-- | Priority classification for a remediation action. +-- +-- Maps directly to quality levels: fixing a 'PriorityFoundation' issue is +-- prerequisite to addressing 'PriorityStructural' issues, and so on. +data RemediationPriority + = PriorityFoundation + -- ^ Address Level 0 gaps: scaffolding, hooks, verification harnesses. + | PriorityStructural + -- ^ Address Level 1 gaps: Tagref, linkcheck cross-reference integrity. + | PriorityCompiler + -- ^ Address Level 2 gaps: compiler warnings under @-Wall -Wcompat@. + | PriorityAnalysis + -- ^ Address Level 3 gaps: HLint hints, CLOC density, test suite passage. + deriving stock (Eq, Ord, Show, Generic) + +-- | Human-readable label for a 'RemediationPriority'. +remediationPriorityName :: RemediationPriority -> Text +remediationPriorityName = \case + PriorityFoundation -> "Foundation (L0)" + PriorityStructural -> "Structural (L1)" + PriorityCompiler -> "Compiler (L2)" + PriorityAnalysis -> "Analysis (L3)" + +-- | A single actionable remediation step with priority, description, and +-- a suggested command or action to resolve the gap. +data RemediationStep = RemediationStep + { stepPriority :: !RemediationPriority + -- ^ Priority classification determining remediation sequencing. + , stepGateName :: !Text + -- ^ Name of the failing gate this step addresses. + , stepDescription :: !Text + -- ^ Human-readable explanation of the gap and its impact. + , stepCommand :: !Text + -- ^ Suggested shell command or action to resolve the gap. + } deriving stock (Eq, Show, Generic) + +-------------------------------------------------------------------------------- +-- 4. Pure Gate Construction +-------------------------------------------------------------------------------- + +-- | Level 0 gates: Foundation checks verifying scaffolding and harness presence. +-- +-- Per Note [Progressive Quality Gate Realization and Incremental Compliance Levels] +-- [ref:note-progressive-quality-gates], Level 0 validates that the physical +-- infrastructure established by Milestones 4.1 and 4.2 is in place: +-- Git repository initialized, hooks directory present, turnkey verification +-- scripts present with executable permissions, and critical documentation installed. +level0Gates :: [GateCheck] +level0Gates = + [ GateCheck + { gateName = "Git Repository Initialized" + , gateLevel = QualityLevel0 + , gateDescription = ".git directory exists at repository root" + , gateEvaluator = \root -> doesDirectoryExist (root ".git") + `catch` (\(_ :: SomeException) -> pure False) + } + , GateCheck + { gateName = "Git Hooks Directory" + , gateLevel = QualityLevel0 + , gateDescription = ".githooks/ directory exists with commit-msg and pre-commit hooks" + , gateEvaluator = \root -> do + hasDir <- doesDirectoryExist (root ".githooks") + `catch` (\(_ :: SomeException) -> pure False) + if hasDir + then do + hasCm <- doesFileExist (root ".githooks" "commit-msg") + `catch` (\(_ :: SomeException) -> pure False) + hasPc <- doesFileExist (root ".githooks" "pre-commit") + `catch` (\(_ :: SomeException) -> pure False) + pure (hasCm && hasPc) + else pure False + } + , GateCheck + { gateName = "Verification Runner Script" + , gateLevel = QualityLevel0 + , gateDescription = "Turnkey bin/*-verify or bin/verify script present with +x permissions" + , gateEvaluator = \root -> do + hasBin <- doesDirectoryExist (root "bin") + `catch` (\(_ :: SomeException) -> pure False) + if hasBin + then do + entries <- listDirectory (root "bin") + `catch` (\(_ :: SomeException) -> pure []) + let verifyScripts = filter (\e -> "-verify" `isSuffixOfS` e || e == "verify") entries + case verifyScripts of + (s:_) -> do + perms <- getPermissions (root "bin" s) + pure (executable perms) + `catch` (\(_ :: SomeException) -> pure False) + [] -> pure False + else pure False + } + , GateCheck + { gateName = "Tagref Configuration" + , gateLevel = QualityLevel0 + , gateDescription = "tagref.yml or .tagref configuration file present" + , gateEvaluator = \root -> do + hasTagref <- doesFileExist (root "tagref.yml") + `catch` (\(_ :: SomeException) -> pure False) + hasDotTagref <- doesFileExist (root ".tagref") + `catch` (\(_ :: SomeException) -> pure False) + pure (hasTagref || hasDotTagref) + } + , GateCheck + { gateName = "HLint Configuration" + , gateLevel = QualityLevel0 + , gateDescription = ".hlint.yaml linter configuration present" + , gateEvaluator = \root -> doesFileExist (root ".hlint.yaml") + `catch` (\(_ :: SomeException) -> pure False) + } + , GateCheck + { gateName = "README Documentation" + , gateLevel = QualityLevel0 + , gateDescription = "README.md orientation document present" + , gateEvaluator = \root -> doesFileExist (root "README.md") + `catch` (\(_ :: SomeException) -> pure False) + } + , GateCheck + { gateName = "Strategic Roadmap" + , gateLevel = QualityLevel0 + , gateDescription = "PLAN.md operational roadmap present" + , gateEvaluator = \root -> doesFileExist (root "PLAN.md") + `catch` (\(_ :: SomeException) -> pure False) + } + , GateCheck + { gateName = "Git Message Template" + , gateLevel = QualityLevel0 + , gateDescription = ".gitmessage commit template present" + , gateEvaluator = \root -> doesFileExist (root ".gitmessage") + `catch` (\(_ :: SomeException) -> pure False) + } + ] + +-- | Level 1 gates: Structural integrity via cross-reference and link validation. +-- +-- Per Note [Progressive Quality Gate Realization and Incremental Compliance Levels] +-- [ref:note-progressive-quality-gates], Level 1 evaluates whether Tagref +-- cross-references and Markdown links are internally consistent. +-- Gates invoke external tools (@tagref@, @lychee@ / @markdown-link-check@) if available, +-- or degrade gracefully by inspecting harness scripts. +level1Gates :: [GateCheck] +level1Gates = + [ GateCheck + { gateName = "Tagref Cross-Reference Integrity" + , gateLevel = QualityLevel1 + , gateDescription = "Zero dangling tag and ref cross-references" + , gateEvaluator = \root -> do + -- Attempt to run a tagref harness script if present + tagrefResult <- findAndRunHarness root "tagref" + case tagrefResult of + Just exitOk -> pure exitOk + Nothing -> do + -- Fall back to direct tagref invocation + (code, _, _) <- readProcessWithExitCode "tagref" ["--dir", root] "" + `catch` (\(_ :: SomeException) -> pure (ExitSuccess, "", "")) + pure (code == ExitSuccess) + } + , GateCheck + { gateName = "Markdown Link Integrity" + , gateLevel = QualityLevel1 + , gateDescription = "Zero broken Markdown links and anchors" + , gateEvaluator = \root -> do + -- Attempt to run a linkcheck harness script if present + linkResult <- findAndRunHarness root "linkcheck" + case linkResult of + Just exitOk -> pure exitOk + Nothing -> + -- Check whether markdown files contain plausibly valid links + -- (graceful degradation when no external tool is available) + doesFileExist (root "README.md") + `catch` (\(_ :: SomeException) -> pure False) + } + ] + +-- | Level 2 gates: Compiler discipline under strict warning flags. +-- +-- Per Note [Progressive Quality Gate Realization and Incremental Compliance Levels] +-- [ref:note-progressive-quality-gates], Level 2 validates that the codebase +-- compiles cleanly under @-Wall -Wcompat -Wredundant-constraints@ with zero +-- warnings. This is checked by inspecting @cabal build all@ output. +level2Gates :: [GateCheck] +level2Gates = + [ GateCheck + { gateName = "Cabal Build Clean (-Wall)" + , gateLevel = QualityLevel2 + , gateDescription = "cabal build all completes with zero warnings under -Wall -Wcompat" + , gateEvaluator = \root -> do + -- Check if cabal.project or *.cabal exists + hasCabalProject <- doesFileExist (root "cabal.project") + `catch` (\(_ :: SomeException) -> pure False) + paths <- listRepositoryFiles root + let hasCabalFile = any (\p -> ".cabal" `isSuffixOfS` p && '/' `notElem` p) paths + if not (hasCabalProject || hasCabalFile) + then pure True -- Not a Haskell/Cabal project; gate does not apply + else do + (code, out, err) <- readCreateProcessWithExitCode ((proc "cabal" ["--project-dir=" ++ root, "build", "all", "--builddir=" ++ root "dist-newstyle"]) { cwd = Just root }) "" + `catch` (\(_ :: SomeException) -> pure (ExitFailure 1, "", "cabal not found")) + let combined = out ++ err + -- Count GHC warning lines (pattern: "warning:" or "Warning:") + warningCount = length (filter isWarningLine (lines combined)) + pure (code == ExitSuccess && warningCount == 0) + } + ] + +-- | Level 3 gates: Static analysis purity — HLint, CLOC density, and test suite. +-- +-- Per Note [Progressive Quality Gate Realization and Incremental Compliance Levels] +-- [ref:note-progressive-quality-gates], Level 3 enforces: +-- * Zero HLint hints under the project's @.hlint.yaml@ configuration. +-- * Comment density meeting the 25.0% gate threshold on production code. +-- * Full test suite passing via @cabal test all@. +level3Gates :: [GateCheck] +level3Gates = + [ GateCheck + { gateName = "HLint Zero Hints" + , gateLevel = QualityLevel3 + , gateDescription = "HLint reports zero hints across all production source files" + , gateEvaluator = \root -> do + -- Check if HLint config exists (required for meaningful analysis) + hasHlint <- doesFileExist (root ".hlint.yaml") + `catch` (\(_ :: SomeException) -> pure False) + if not hasHlint + then pure False -- No config means L3 cannot be achieved + else do + -- Determine source directories to scan + let srcDirs = determineSrcDirs root + results <- mapM (runHlintOnDir root) srcDirs + pure (and results) + } + , GateCheck + { gateName = "Comment Density Gate" + , gateLevel = QualityLevel3 + , gateDescription = "In-code comment density >= 25.0% threshold on production source" + , gateEvaluator = \root -> do + -- Attempt to run the CLOC harness if present + clocResult <- findAndRunHarness root "cloc" + case clocResult of + Just exitOk -> pure exitOk + Nothing -> do + -- Check presence of CLOC tool for direct execution + (code, out, _) <- readCreateProcessWithExitCode ((proc "cloc" ["--quiet", "--csv", root "src"]) { cwd = Just root }) "" + `catch` (\(_ :: SomeException) -> pure (ExitFailure 1, "", "")) + -- Parse CLOC CSV output for comment ratio + if code /= ExitSuccess + then pure True -- Graceful degradation when cloc is unavailable + else pure (parseClocDensity out >= 25.0) + } + , GateCheck + { gateName = "Full Test Suite" + , gateLevel = QualityLevel3 + , gateDescription = "cabal test all passes with zero failures" + , gateEvaluator = \root -> do + hasCabalProject <- doesFileExist (root "cabal.project") + `catch` (\(_ :: SomeException) -> pure False) + paths <- listRepositoryFiles root + let hasCabalFile = any (\p -> ".cabal" `isSuffixOfS` p && '/' `notElem` p) paths + if not (hasCabalProject || hasCabalFile) + then pure True -- Not a Haskell/Cabal project; gate does not apply + else do + (code, _, _) <- readCreateProcessWithExitCode ((proc "cabal" ["--project-dir=" ++ root, "test", "all", "--builddir=" ++ root "dist-newstyle"]) { cwd = Just root }) "" + `catch` (\(_ :: SomeException) -> pure (ExitFailure 1, "", "")) + pure (code == ExitSuccess) + } + ] + +-- | All quality gates across all four levels, in ascending level order. +allLevelGates :: [GateCheck] +allLevelGates = level0Gates ++ level1Gates ++ level2Gates ++ level3Gates + +-------------------------------------------------------------------------------- +-- 5. Evaluation Engine +-------------------------------------------------------------------------------- + +-- | Evaluates a single gate check against a target repository root directory. +-- +-- Wraps the gate's evaluation function in exception handling to guarantee +-- graceful degradation: a gate that throws an exception is reported as failed +-- with the exception message as diagnostic detail. +evaluateGateCheck :: FilePath -> GateCheck -> IO GateResult +evaluateGateCheck root gc = do + absRoot <- makeAbsolute root `catch` (\(_ :: SomeException) -> pure root) + result <- gateEvaluator gc absRoot `catch` handleException + pure GateResult + { resultGate = gc + , resultPassed = result + , resultDetail = if result + then "PASS" + else "FAIL: " <> gateDescription gc + } + where + handleException :: SomeException -> IO Bool + handleException _ = pure False + +-- | Computes the highest quality level achieved given a list of gate results. +-- +-- A level is "achieved" if and only if every gate belonging to that level and +-- all preceding levels has passed. If any Level 0 gate fails, the achieved +-- level remains below Level 0 (reported as 'QualityLevel0' with failures noted). +-- +-- === Monotonic Progression Invariant +-- +-- @ +-- achieved(results) = max { L | ∀ g ∈ gates(≤L) : passed(g) } +-- @ +computeAchievedLevel :: [GateResult] -> QualityLevel +computeAchievedLevel results + | not (allPassedAtLevel QualityLevel0) = QualityLevel0 + | not (allPassedAtLevel QualityLevel1) = QualityLevel0 + | not (allPassedAtLevel QualityLevel2) = QualityLevel1 + | not (allPassedAtLevel QualityLevel3) = QualityLevel2 + | otherwise = QualityLevel3 + where + allPassedAtLevel lvl = + all resultPassed (filter (\r -> gateLevel (resultGate r) == lvl) results) + +-- | Generates prioritized remediation steps from failing gate results. +-- +-- Each failing gate is translated into an actionable 'RemediationStep' with +-- the appropriate priority classification and a suggested command. Steps are +-- ordered by ascending quality level (foundation first, analysis last). +computeRemediationSteps :: [GateResult] -> [RemediationStep] +computeRemediationSteps = concatMap stepFromResult . filter (not . resultPassed) + where + stepFromResult gr = + let gc = resultGate gr + priority = levelToPriority (gateLevel gc) + cmd = suggestCommand (gateName gc) + in [ RemediationStep + { stepPriority = priority + , stepGateName = gateName gc + , stepDescription = gateDescription gc + , stepCommand = cmd + } + ] + + levelToPriority = \case + QualityLevel0 -> PriorityFoundation + QualityLevel1 -> PriorityStructural + QualityLevel2 -> PriorityCompiler + QualityLevel3 -> PriorityAnalysis + + -- | Suggests a concrete remediation command for each named gate. + suggestCommand :: Text -> Text + suggestCommand name + | "Git Repository" `T.isInfixOf` name = "gachi retrofit --target . (or: git init)" + | "Git Hooks" `T.isInfixOf` name = "gachi retrofit --target . (installs .githooks/)" + | "Verification Runner" `T.isInfixOf` name = "gachi retrofit --target . (installs bin/-verify)" + | "Tagref Configuration" `T.isInfixOf` name = "gachi retrofit --target . (installs tagref.yml)" + | "HLint Configuration" `T.isInfixOf` name = "gachi retrofit --target . (installs .hlint.yaml)" + | "README" `T.isInfixOf` name = "gachi retrofit --target . (scaffolds README.md)" + | "Strategic Roadmap" `T.isInfixOf` name = "gachi retrofit --target . (scaffolds PLAN.md)" + | "Git Message" `T.isInfixOf` name = "gachi retrofit --target . (installs .gitmessage)" + | "Tagref Cross-Reference" `T.isInfixOf` name = "tagref --dir . (fix dangling cross-references)" + | "Markdown Link" `T.isInfixOf` name = "Fix broken links in *.md files (check relative paths)" + | "Cabal Build" `T.isInfixOf` name = "cabal build all 2>&1 | grep -i warning (fix each warning)" + | "HLint Zero" `T.isInfixOf` name = "hlint src/ packages/*/src/ --hint=.hlint.yaml (fix each hint)" + | "Comment Density" `T.isInfixOf` name = "Add Haddock comments to reach >= 25.0% density" + | "Full Test" `T.isInfixOf` name = "cabal test all (fix failing tests)" + | otherwise = "Review and address: " <> name + +-- | Evaluates all quality gates against the target repository and produces +-- a comprehensive 'QualityGateReport'. +-- +-- === Evaluation Workflow +-- +-- 1. Infers the project name from build manifests or directory basename. +-- 2. Evaluates all Level 0–3 gates sequentially via 'evaluateGateCheck'. +-- 3. Computes the highest achieved level via 'computeAchievedLevel'. +-- 4. Generates prioritized remediation steps via 'computeRemediationSteps'. +-- +-- All gate evaluations are strictly non-destructive per Note [Non-Destructive +-- Skeleton Overlay] [ref:note-nondestructive-retrofit]. +evaluateQualityGates :: FilePath -> IO QualityGateReport +evaluateQualityGates root = do + -- Infer project name + paths <- listRepositoryFiles root + let projName = inferProjectName root [] paths + + -- Evaluate all gates + results <- mapM (evaluateGateCheck root) allLevelGates + + let achieved = computeAchievedLevel results + passed = length (filter resultPassed results) + failed = length (filter (not . resultPassed) results) + steps = computeRemediationSteps results + + pure QualityGateReport + { qgTargetDir = root + , qgProjectName = projName + , qgGateResults = results + , qgAchievedLevel = achieved + , qgMaxPossibleLevel = QualityLevel3 + , qgPassedCount = passed + , qgFailedCount = failed + , qgRemediationSteps = steps + } + +-------------------------------------------------------------------------------- +-- 6. Pretty-Printing & Dashboards +-------------------------------------------------------------------------------- + +-- | Formats a 'QualityGateReport' as an 80-column aligned ASCII terminal dashboard. +-- +-- Features boxed section headers, Unicode progress indicators, per-level gate +-- checklists with pass/fail markers, and a prioritized remediation action plan. +-- +-- === Layout +-- +-- @ +-- ================================================================================ +-- Gachi Progressive Quality Gate Report (~/src/PLAN.md §1.A, Milestone 4.3) +-- ================================================================================ +-- Target Directory: /path/to/project +-- Project Identifier: my-project +-- Achieved Level: Level 2: Compiler Discipline +-- Gates Passed: 11 / 14 +-- -------------------------------------------------------------------------------- +-- [Level 0: Foundation] +-- [✓] Git Repository Initialized +-- [✓] Git Hooks Directory +-- ... +-- [Level 1: Structural Integrity] +-- [✓] Tagref Cross-Reference Integrity +-- ... +-- ================================================================================ +-- @ +formatQualityGateReport :: QualityGateReport -> Text +formatQualityGateReport rpt = T.unlines $ + [ separator + , " Gachi Progressive Quality Gate Report (~/src/PLAN.md §1.A, Milestone 4.3)" + , separator + , " Target Directory: " <> T.pack (qgTargetDir rpt) + , " Project Identifier: " <> qgProjectName rpt + , " Achieved Level: " <> qualityLevelName (qgAchievedLevel rpt) + , " Gates Passed: " <> T.pack (show (qgPassedCount rpt)) + <> " / " + <> T.pack (show (qgPassedCount rpt + qgFailedCount rpt)) + , thinSeparator + ] + ++ formatLevelSection QualityLevel0 (qgGateResults rpt) + ++ formatLevelSection QualityLevel1 (qgGateResults rpt) + ++ formatLevelSection QualityLevel2 (qgGateResults rpt) + ++ formatLevelSection QualityLevel3 (qgGateResults rpt) + ++ formatRemediationSection (qgRemediationSteps rpt) + ++ [separator] + where + separator = T.replicate 80 "=" + thinSeparator = T.replicate 80 "-" + + formatLevelSection :: QualityLevel -> [GateResult] -> [Text] + formatLevelSection lvl results = + let levelResults = filter (\r -> gateLevel (resultGate r) == lvl) results + in if null levelResults + then [] + else (" [" <> qualityLevelName lvl <> "]") + : map formatGateResult levelResults + ++ [""] + + formatGateResult :: GateResult -> Text + formatGateResult gr = + let marker = if resultPassed gr then "✓" else "✗" + name = gateName (resultGate gr) + in " [" <> marker <> "] " <> name + + formatRemediationSection :: [RemediationStep] -> [Text] + formatRemediationSection [] = + [ thinSeparator + , " All quality gates PASSED. Compliance: " <> qualityLevelName (qgAchievedLevel rpt) <> "." + , "" + ] + formatRemediationSection steps = + [ thinSeparator + , " Remediation Plan (next steps to advance from " + <> qualityLevelName (qgAchievedLevel rpt) <> "):" + , "" + ] + ++ zipWith formatStep ([1..] :: [Int]) steps + ++ [""] + + formatStep :: Int -> RemediationStep -> Text + formatStep n step = + " " <> T.pack (show n) <> ". [" <> remediationPriorityName (stepPriority step) <> "] " + <> stepGateName step <> ": " <> stepCommand step + +-- | Formats a 'QualityGateReport' as a GitHub-Flavored Markdown document. +-- +-- Produces structured markdown with heading hierarchy, GFM tables for gate results, +-- and an actionable remediation checklist. Suitable for @QUALITY_REPORT.md@ or +-- CI pipeline artifact rendering. +formatQualityGateMarkdown :: QualityGateReport -> Text +formatQualityGateMarkdown rpt = T.unlines $ + [ "# Progressive Quality Gate Report: `" <> qgProjectName rpt <> "`" + , "" + , "| Property | Value |" + , "|---|---|" + , "| **Target Directory** | `" <> T.pack (qgTargetDir rpt) <> "` |" + , "| **Project Name** | " <> qgProjectName rpt <> " |" + , "| **Achieved Level** | " <> qualityLevelName (qgAchievedLevel rpt) <> " |" + , "| **Gates Passed** | " <> T.pack (show (qgPassedCount rpt)) + <> " / " + <> T.pack (show (qgPassedCount rpt + qgFailedCount rpt)) <> " |" + , "" + ] + ++ formatMarkdownLevel QualityLevel0 (qgGateResults rpt) + ++ formatMarkdownLevel QualityLevel1 (qgGateResults rpt) + ++ formatMarkdownLevel QualityLevel2 (qgGateResults rpt) + ++ formatMarkdownLevel QualityLevel3 (qgGateResults rpt) + ++ formatMarkdownRemediation (qgRemediationSteps rpt) + where + formatMarkdownLevel :: QualityLevel -> [GateResult] -> [Text] + formatMarkdownLevel lvl results = + let levelResults = filter (\r -> gateLevel (resultGate r) == lvl) results + in if null levelResults + then [] + else [ "## " <> qualityLevelName lvl + , "" + , "| Status | Gate | Description |" + , "|---|---|---|" + ] + ++ map formatMarkdownGate levelResults + ++ [""] + + formatMarkdownGate :: GateResult -> Text + formatMarkdownGate gr = + let status = if resultPassed gr then "✅ PASS" else "❌ FAIL" + name = gateName (resultGate gr) + desc = gateDescription (resultGate gr) + in "| " <> status <> " | " <> name <> " | " <> desc <> " |" + + formatMarkdownRemediation :: [RemediationStep] -> [Text] + formatMarkdownRemediation [] = + [ "## Compliance Status" + , "" + , "> All quality gates passed. Achieved: **" <> qualityLevelName (qgAchievedLevel rpt) <> "**." + , "" + ] + formatMarkdownRemediation steps = + [ "## Remediation Plan" + , "" + ] + ++ map formatMarkdownStep steps + ++ [""] + + formatMarkdownStep :: RemediationStep -> Text + formatMarkdownStep step = + "- [ ] **[" <> remediationPriorityName (stepPriority step) <> "]** " + <> stepGateName step <> ": `" <> stepCommand step <> "`" + +-------------------------------------------------------------------------------- +-- 7. Internal Helpers +-------------------------------------------------------------------------------- + +-- | Attempts to locate and execute a turnkey verification harness script +-- (e.g. @bin/-tagref@) within the target repository. +-- +-- Returns 'Just True' if the harness executed successfully (exit code 0), +-- 'Just False' if it failed, or 'Nothing' if no harness was found. +findAndRunHarness :: FilePath -> String -> IO (Maybe Bool) +findAndRunHarness root harnessType = do + hasBin <- doesDirectoryExist (root "bin") + `catch` (\(_ :: SomeException) -> pure False) + if not hasBin + then pure Nothing + else do + entries <- listDirectory (root "bin") + `catch` (\(_ :: SomeException) -> pure []) + let matches = filter (\e -> ("-" ++ harnessType) `isSuffixOfS` e || e == harnessType) entries + case matches of + (script:_) -> do + let scriptPath = root "bin" script + (code, _, _) <- readCreateProcessWithExitCode ((proc scriptPath []) { cwd = Just root }) "" + `catch` (\(_ :: SomeException) -> pure (ExitFailure 1, "", "")) + pure (Just (code == ExitSuccess)) + [] -> pure Nothing + +-- | Determines the source directories to scan for HLint in a target repository. +-- +-- Checks for multi-package layout (@packages/*/src@) and single-package layout +-- (@src/@), returning all existing source directories. +determineSrcDirs :: FilePath -> [FilePath] +determineSrcDirs _root = ["src", "packages"] + +-- | Runs HLint on a specific directory within the target repository. +runHlintOnDir :: FilePath -> FilePath -> IO Bool +runHlintOnDir root srcDir = do + let fullPath = root srcDir + exists <- doesDirectoryExist fullPath + `catch` (\(_ :: SomeException) -> pure False) + if not exists + then pure True -- Directory does not exist; no hints possible + else do + (_code, out, _) <- readCreateProcessWithExitCode ((proc "hlint" [fullPath, "--hint=" ++ root ".hlint.yaml", "--no-exit-code"]) { cwd = Just root }) "" + `catch` (\(_ :: SomeException) -> pure (ExitSuccess, "No suggestions", "")) + -- HLint with --no-exit-code always returns 0; check output for "No suggestions" or "No hints" + let noHints = "No suggestions" `isInfixOfS` out + || "No hints" `isInfixOfS` out + || null (lines out) + pure noHints + +-- | Checks whether a line contains a GHC warning indicator. +isWarningLine :: String -> Bool +isWarningLine line = + "warning:" `isInfixOfS` line + || "Warning:" `isInfixOfS` line + +-- | Parses CLOC CSV output for comment density percentage. +-- Returns 0.0 if parsing fails. +parseClocDensity :: String -> Double +parseClocDensity output = + let csvLines = filter (not . null) (lines output) + in case csvLines of + [] -> 0.0 + _ -> extractDensity csvLines + +-- | Extracts comment density from CLOC CSV lines. +extractDensity :: [String] -> Double +extractDensity csvLines = + let summaryLine = last csvLines + fields = splitOnComma summaryLine + in case fields of + -- CLOC CSV columns: files, language, blank, comment, code + (_:_:_:commentStr:codeStr:_) -> + let comments = readMaybe commentStr + code = readMaybe codeStr + in case (comments, code) of + (Just c, Just k) | k > 0 -> (c / (c + k)) * 100.0 + _ -> 0.0 + _ -> 0.0 + +-- | Simple comma-separated field splitter. +splitOnComma :: String -> [String] +splitOnComma [] = [""] +splitOnComma (',':rest) = "" : splitOnComma rest +splitOnComma (c:rest) = case splitOnComma rest of + (f:fs) -> (c:f) : fs + [] -> [[c]] + +-- | Safe read with default to Nothing. +readMaybe :: String -> Maybe Double +readMaybe s = case reads (filter (/= '"') s) of + [(v, "")] -> Just v + _ -> Nothing + +-- | String infix check helper. +isInfixOfS :: String -> String -> Bool +isInfixOfS needle haystack = needle `elem` tails' haystack + where + tails' [] = [""] + tails' xs@(_:rest) = take (length needle) xs : tails' rest + +-- | String suffix check helper. +isSuffixOfS :: String -> String -> Bool +isSuffixOfS sfx str = drop (length str - length sfx) str == sfx + diff --git a/src/Gachi/Retrofit/Report.hs b/src/Gachi/Retrofit/Report.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Retrofit/Report.hs @@ -0,0 +1,349 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Module: Gachi.Retrofit.Report +-- Description: Diagnostic report formatting and pretty-printing +-- +-- This module renders 'DiagnosticReport' data structures into aligned ASCII terminal +-- dashboards, GitHub-Flavored Markdown documents, and compact single-line summaries. +-- +-- = Architectural Context & Invariants +-- +-- Per Note [Non-Destructive Skeleton Overlay] [ref:note-nondestructive-retrofit], +-- diagnostic reports provide complete observability into legacy or external repositories +-- without altering any target files. +-- +-- == Pretty-Printing Philosophy & Formats +-- +-- The reporting layer provides three distinct output modalities: +-- +-- 1. __Aligned ASCII Terminal Dashboard ('formatDiagnosticReport'):__ +-- Optimized for high-information-density terminal display. Features 80-column boxed +-- headers, Unicode progress indicators ('renderScoreBar'), aligned tabular breakdowns +-- for programming languages and documentation gaps, and status checklists for Git hooks +-- and verification gates. +-- +-- 2. __GitHub-Flavored Markdown ('formatDiagnosticMarkdown'):__ +-- Structured markdown document suitable for piping into @RETROFIT_PLAN.md@, generating +-- pull request descriptions, or saving as CI workflow artifacts. +-- +-- 3. __Single-Line Summary ('formatDiagnosticSummaryLine'):__ +-- Concise one-line status string intended for log streaming, batch audits, or CI step summaries. +-- +-- = Worked Example +-- +-- >>> import Gachi.Retrofit.Diagnostic (scanRepository) +-- >>> report <- scanRepository "." +-- >>> let textReport = formatDiagnosticReport report +-- >>> T.null textReport +-- False +-- >>> let summary = formatDiagnosticSummaryLine report +-- >>> "gachi retrofit inspect" `T.isInfixOf` summary +-- True +module Gachi.Retrofit.Report + ( -- * Report Formatters + formatDiagnosticReport + , formatDiagnosticMarkdown + , formatDiagnosticSummaryLine + + -- * Helper Rendering Primitives + , renderScoreBar + , scoreClassification + , padRight + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import Gachi.Retrofit.Types + +-------------------------------------------------------------------------------- +-- 1. ASCII Terminal Dashboard Formatting +-------------------------------------------------------------------------------- + +-- | Formats a 'DiagnosticReport' as an aligned ASCII terminal dashboard. +-- +-- Renders an 80-column summary dashboard presenting: +-- * Workspace identity, primary language, layout classification, and build tools. +-- * 20-character Unicode progress bar representing the overall retrofit readiness score. +-- * Section [1]: Detailed programming language distribution table. +-- * Section [2]: Test infrastructure status, directories, and declared suites. +-- * Section [3]: Complete @DOC_STRATEGY.md@ documentation checklist. +-- * Section [4]: Git governance, hook permissions, and RFC 2822 trailer status. +-- * Section [5]: 5-gate physical verification harness status. +-- * Section [6]: Prioritized, numbered remediation action plan for Phase 4. +formatDiagnosticReport :: DiagnosticReport -> Text +formatDiagnosticReport r = + T.unlines + [ banner + , " Gachi Diagnostic Repository Inspector (~/src/PLAN.md §1.A, Milestone 4.1)" + , banner + , " Target Directory: " <> T.pack (diagTargetDir r) + , " Project Identifier: " <> diagProjectName r + , " Primary Language: " <> maybe "Unknown" languageName (diagPrimaryLanguage r) + , " Workspace Layout: " <> layoutName (diagLayout r) + , " Build Systems: " <> formatBuildList (diagBuildSystems r) + , " Packages Detected: " <> formatPackages (diagDiscoveredPackages r) + , divider + , " Ecosystem Retrofit Score: " <> renderScoreBar (diagRetrofitScore r) <> " " <> T.pack (show (diagRetrofitScore r)) <> "% (" <> scoreClassification (diagRetrofitScore r) <> ")" + , banner + , "" + , " [1] Programming Language Breakdown" + , divider + , formatLanguageTable (diagLanguages r) + , "" + , " [2] Test Infrastructure" + , divider + , formatTestSection (diagTestInfra r) + , "" + , " [3] Documentation Inventory (DOC_STRATEGY.md Compliance: " <> T.pack (show (diagDocCompliancePct r)) <> "%)" + , divider + , formatDocTable (diagDocGaps r) + , "" + , " [4] Git Governance & Commit Attribution" + , divider + , formatGitSection (diagGitGovernance r) + , "" + , " [5] Physical Verification Harnesses & Quality Gates" + , divider + , formatVerificationSection (diagVerificationHarness r) + , "" + , " [6] Prioritized Phase 4 Remediation Plan" + , divider + , formatRemediationPlan (diagRemediationPlan r) + , banner + ] + where + banner = T.replicate 80 "=" + divider = T.replicate 80 "-" + + formatBuildList [] = "None detected (Unstructured)" + formatBuildList bs = T.intercalate ", " (map buildSystemName bs) + + formatPackages [] = "None (Single root package or non-Cabal layout)" + formatPackages ps = "[" <> T.intercalate ", " ps <> "]" + +-------------------------------------------------------------------------------- +-- 2. Section Formatters +-------------------------------------------------------------------------------- + +-- | Formats the language distribution table. +-- +-- Renders columns: Language, Files, Share (%), and Extensions. +formatLanguageTable :: [LanguageStats] -> Text +formatLanguageTable [] = " No recognized source code files discovered." +formatLanguageTable stats = + let hdr = " Language | Files | Share (%) | Extensions" + sep = " -----------------+------------+------------+---------------------------" + rows = map renderRow stats + in T.unlines (hdr : sep : rows) + where + renderRow s = + let lang = padRight 16 (languageName (langType s)) + files = padRight 10 (T.pack (show (langFiles s))) + share = padRight 10 (T.pack (show (langPercentage s)) <> "%") + exts = T.intercalate ", " (langExtensions s) + in " " <> lang <> " | " <> files <> " | " <> share <> " | " <> exts + +-- | Formats the test infrastructure section. +-- +-- Renders test directories, test file counts, and declared test suites with frameworks. +formatTestSection :: TestInfrastructure -> Text +formatTestSection t + | not (hasTests t) = + T.unlines + [ " Status: [-] NO TESTS DETECTED" + , " Recommendation: Establish baseline test suite in test/ or packages/*/test." + ] + | otherwise = + let dirList = if null (testDirectories t) then "None" else T.intercalate ", " (map T.pack (testDirectories t)) + suiteSummary = if null (testSuites t) then "None declared" else T.intercalate "; " (map formatSuite (testSuites t)) + in T.unlines + [ " Status: [+] TEST INFRASTRUCTURE DETECTED" + , " Test Files Found: " <> T.pack (show (testFileCount t)) <> " files" + , " Directories: " <> dirList + , " Declared Suites: " <> suiteSummary + ] + where + formatSuite s = + testSuiteName s <> " (" <> T.intercalate ", " (map testFrameworkName (testFrameworks s)) <> ")" + +-- | Formats the @DOC_STRATEGY.md@ documentation checklist. +-- +-- Renders columns: Status ([+] / [-]), Severity, Path, and Category. +formatDocTable :: [DocGap] -> Text +formatDocTable [] = " No documentation items evaluated." +formatDocTable docs = + let hdr = " Status | Severity | Path | Category" + sep = " -------+-------------+------------------------------+--------------------------" + rows = map renderRow docs + in T.unlines (hdr : sep : rows) + where + renderRow d = + let st = if docPresent d then "[+] OK " else "[-] MISS" + sev = padRight 11 (docSeverityName (docSeverity d)) + pth = padRight 28 (T.pack (docPath d)) + cat = docCategoryName (docCategory d) + in " " <> st <> " | " <> sev <> " | " <> pth <> " | " <> cat + +-- | Formats Git governance status. +-- +-- Reports status of @.git@, @.githooks@, @core.hooksPath@, @commit-msg@, @pre-commit@, +-- Sarutahiko attribution checks, and @.gitmessage@. +formatGitSection :: GitGovernanceStatus -> Text +formatGitSection g = + T.unlines + [ " Git Repository: " <> check (hasGitRepo g) "Initialized (.git exists)" "NOT INITIALIZED" + , " Hooks Directory: " <> check (hasHooksDir g) "Standard (.githooks exists)" "Missing (.githooks not found)" + , " core.hooksPath: " <> maybe "[-] Unconfigured (defaults to .git/hooks)" ("[+] Configured: " <>) (hooksPathConfig g) + , " commit-msg Hook: " <> check (hasCommitMsgHook g) (if isCommitMsgExecutable g then "Executable (+x)" else "Present but NOT executable") "Missing" + , " AI Trailer Check: " <> check (hasCommitMsgAttributionCheck g) "Enforcing RFC 2822 Assisted-by: trailers" "Attribution validation missing" + , " pre-commit Hook: " <> check (hasPreCommitHook g) (if isPreCommitExecutable g then "Executable (+x)" else "Present but NOT executable") "Missing" + , " Commit Template: " <> check (hasGitMessageTemplate g) ".gitmessage present" "Missing .gitmessage" + , " commit.template: " <> maybe "[-] Unconfigured in git config" ("[+] Configured: " <>) (gitMessageConfig g) + ] + where + check True ok _ = "[+] " <> ok + check False _ miss = "[-] " <> miss + +-- | Formats verification harness status. +-- +-- Reports presence and status of turnkey verify script, Tagref, linkcheck, CLOC, +-- and linters. +formatVerificationSection :: VerificationHarnessStatus -> Text +formatVerificationSection v = + T.unlines + [ " Turnkey Runner: " <> maybe "[-] Missing (bin/*-verify)" (\p -> "[+] " <> T.pack p) (verifyScriptPath v) + , " Tagref Harness: " <> check (hasTagrefHarness v || hasTagrefConfig v) "Active (tagref.yml / bin/*-tagref)" "Missing" + , " Linkcheck Harness: " <> check (hasLinkcheckHarness v) "Active (bin/*-linkcheck)" "Missing" + , " CLOC Harness: " <> check (hasClocHarness v) "Active (bin/*-cloc)" "Missing" + , " HLint Config: " <> check (hasHlintConfig v) "Active (.hlint.yaml)" "Missing" + , " Fourmolu Config: " <> check (hasFourmoluConfig v) "Active (fourmolu.yaml)" "Missing" + ] + where + check True ok _ = "[+] " <> ok + check False _ miss = "[-] " <> miss + +-- | Formats prioritized remediation actions. +-- +-- Displays numbered steps guiding the developer on required Phase 4 actions. +formatRemediationPlan :: [Text] -> Text +formatRemediationPlan [] = " [+] Total ecosystem compliance: 0 remediation actions required!" +formatRemediationPlan plan = + let numbered = zipWith (\(n :: Int) item -> " " <> T.pack (show n) <> ". " <> item) [1..] plan + in T.unlines numbered + +-------------------------------------------------------------------------------- +-- 3. Markdown Output Formatting +-------------------------------------------------------------------------------- + +-- | Formats the diagnostic report as structured GitHub-Flavored Markdown. +-- +-- Suitable for generating @RETROFIT_PLAN.md@, pull request descriptions, or CI summary +-- artifacts. Includes formatted Markdown tables for languages and documentation items. +formatDiagnosticMarkdown :: DiagnosticReport -> Text +formatDiagnosticMarkdown r = + T.unlines + [ "# Diagnostic Repository Inspection Report: `" <> diagProjectName r <> "`" + , "" + , "**Status:** EVALUATED · Milestone 4.1 Diagnostic Inspector " + , "**Target Directory:** `" <> T.pack (diagTargetDir r) <> "` " + , "**Retrofit Readiness Score:** **" <> T.pack (show (diagRetrofitScore r)) <> "%** (" <> scoreClassification (diagRetrofitScore r) <> ") " + , "**DOC_STRATEGY.md Compliance:** **" <> T.pack (show (diagDocCompliancePct r)) <> "%**" + , "" + , "---" + , "" + , "## 1. Programming Languages" + , "" + , "| Language | Files | Share | Extensions |" + , "|---|---|---|---|" + , T.unlines (map renderMdLang (diagLanguages r)) + , "## 2. Build Systems & Architecture" + , "" + , "- **Workspace Layout:** " <> layoutName (diagLayout r) + , "- **Build Toolchains:** " <> T.intercalate ", " (map buildSystemName (diagBuildSystems r)) + , "- **Packages:** " <> if null (diagDiscoveredPackages r) then "None" else T.intercalate ", " (diagDiscoveredPackages r) + , "" + , "## 3. Documentation Gaps" + , "" + , "| Status | Document | Severity | Category |" + , "|---|---|---|---|" + , T.unlines (map renderMdDoc (diagDocGaps r)) + , "## 4. Prioritized Phase 4 Remediation Plan" + , "" + , formatMdRemediation (diagRemediationPlan r) + ] + where + renderMdLang s = + "| " <> languageName (langType s) <> " | " <> T.pack (show (langFiles s)) <> " | " <> T.pack (show (langPercentage s)) <> "% | `" <> T.intercalate ", " (langExtensions s) <> "` |" + + renderMdDoc d = + let st = if docPresent d then "✅ Present" else "❌ Missing" + in "| " <> st <> " | `" <> T.pack (docPath d) <> "` | **" <> docSeverityName (docSeverity d) <> "** | " <> docCategoryName (docCategory d) <> " |" + + formatMdRemediation [] = "*No remediation actions required; codebase is in harmonic ecosystem equilibrium.*" + formatMdRemediation items = + T.unlines (map ("- [ ] " <>) items) + +-------------------------------------------------------------------------------- +-- 4. Compact Summary Line +-------------------------------------------------------------------------------- + +-- | Formats a single-line summary string suitable for logs or streaming output. +-- +-- === Examples +-- +-- >>> let r = DiagnosticReport "." "gachi" (Just LangHaskell) [] [] LayoutMultiPackage [] (TestInfrastructure True [] [] 0) [] 100.0 (GitGovernanceStatus True True Nothing True True True True True True Nothing) (VerificationHarnessStatus True Nothing True True True True True True) 95.0 [] +-- >>> formatDiagnosticSummaryLine r +-- "gachi retrofit inspect [gachi]: Haskell, Multi-Package Workspace Layout (packages/*), Score: 95.0%, 0 critical doc gaps" +formatDiagnosticSummaryLine :: DiagnosticReport -> Text +formatDiagnosticSummaryLine r = + let langStr = maybe "Unknown" languageName (diagPrimaryLanguage r) + critGaps = length (filter (\d -> not (docPresent d) && docSeverity d == SeverityCritical) (diagDocGaps r)) + in "gachi retrofit inspect [" <> diagProjectName r <> "]: " + <> langStr <> ", " + <> layoutName (diagLayout r) <> ", " + <> "Score: " <> T.pack (show (diagRetrofitScore r)) <> "%, " + <> T.pack (show critGaps) <> " critical doc gaps" + +-------------------------------------------------------------------------------- +-- 5. Progress Bars & Helpers +-------------------------------------------------------------------------------- + +-- | Renders a 20-character Unicode block progress bar. +-- +-- Clamps score between 0.0 and 100.0, rendering filled blocks (@█@) and empty blocks (@░@). +-- +-- === Examples +-- +-- >>> renderScoreBar 50.0 +-- "[██████████░░░░░░░░░░]" +-- >>> renderScoreBar 100.0 +-- "[████████████████████]" +renderScoreBar :: Double -> Text +renderScoreBar score = + let clamped = max 0.0 (min 100.0 score) + filledCount = round ((clamped / 100.0) * 20.0) :: Int + emptyCount = max 0 (20 - filledCount) + in "[" <> T.replicate filledCount "█" <> T.replicate emptyCount "░" <> "]" + +-- | Qualitative classification of a numerical retrofit score. +-- +-- Categorizes readiness into four actionable tiers: +-- * >= 90.0: High Conformance +-- * >= 70.0: Moderate Adaptation Needed +-- * >= 40.0: Substantial Retrofit Required +-- * < 40.0: Unstandardized / Raw Codebase +scoreClassification :: Double -> Text +scoreClassification s + | s >= 90.0 = "HIGH CONFORMANCE" + | s >= 70.0 = "MODERATE ADAPTATION NEEDED" + | s >= 40.0 = "SUBSTANTIAL RETROFIT REQUIRED" + | otherwise = "UNSTANDARDIZED / RAW CODEBASE" + +-- | Right-pads a 'Text' value with spaces to achieve the specified minimum column width. +padRight :: Int -> Text -> Text +padRight width txt = + let len = T.length txt + in if len >= width then txt else txt <> T.replicate (width - len) " " diff --git a/src/Gachi/Retrofit/Types.hs b/src/Gachi/Retrofit/Types.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Retrofit/Types.hs @@ -0,0 +1,569 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Module: Gachi.Retrofit.Types +-- Description: Core algebraic data types for repository inspection and retrofitting +-- +-- This module defines the complete data modeling layer for the diagnostic repository +-- inspector and non-destructive retrofitting engine (Milestone 4.1, Phase 4). +-- +-- = Architectural Context & Invariants +-- +-- Per Note [Non-Destructive Skeleton Overlay] [ref:note-nondestructive-retrofit], +-- retrofitting operations adopt legacy, single-package, or foreign repositories into +-- the canonical multi-package ecosystem hierarchy without altering or perturbing +-- domain logic source files (@src/@, @app/@, @lib/@). +-- +-- To achieve this safely, the diagnostic analyzer produces a strongly-typed +-- 'DiagnosticReport' assessing six orthogonal quality and structural dimensions: +-- +-- 1. __Language Stacks & Distributions:__ +-- Classifies discovered source code files into recognized language families ('Language') +-- and computes aggregate file counts and proportions ('LanguageStats'). Identifies the +-- dominant language informing toolchain decisions. +-- +-- 2. __Build Systems & Topographical Layout:__ +-- Discovers build system manifests ('BuildSystem') spanning Cabal, Stack, Cargo, +-- CMake, Make, Meson, Poetry, and Flit. Classifies overall repository layout +-- ('WorkspaceLayout') into single-package, multi-package, polyglot, or unstructured trees. +-- +-- 3. __Test Infrastructure & Frameworks:__ +-- Detects test directories, declared test targets, and testing libraries ('TestFramework', +-- 'TestSuiteInfo', 'TestInfrastructure'). Distinguishes active verification setups from +-- untested codebases. +-- +-- 4. __Documentation Gaps Relative to DOC_STRATEGY.md:__ +-- Audits repository assets against canonical documentation genres ('DocCategory', +-- 'DocSeverity', 'DocGap') per @DOC_STRATEGY.md@ §1, identifying missing orientation, +-- corpus inventory, design rationale, and operational manuals. +-- +-- 5. __Git Governance, Hook Executability & AI Attribution:__ +-- Audits @.git@ directory existence, @core.hooksPath@ configuration, @commit-msg@ hook +-- executability, Sarutahiko / RFC 2822 @Assisted-by:@ trailer validation, @pre-commit@ +-- gates, and @.gitmessage@ commit template pinning ('GitGovernanceStatus'). +-- +-- 6. __Physical Verification Harnesses & Quality Gates:__ +-- Evaluates turnkey test runners (@bin/*-verify@), Tagref cross-reference configuration, +-- Markdown link integrity checkers, and CLOC comment density audit harnesses +-- ('VerificationHarnessStatus'). +-- +-- = The Six Evaluation Dimensions +-- +-- @ +-- +-------------------------------------------------------------------------------+ +-- | Diagnostic Repository Inspector | +-- +-------------------------------------------------------------------------------+ +-- | [1] Languages : Haskell (92.5%), Shell (7.5%) | +-- | [2] Build Systems : Cabal Multi-Package Workspace (cabal.project) | +-- | [3] Test Infra : Hspec test suite (5 files in test/) | +-- | [4] Documentation : DOC_STRATEGY.md Compliance 90.0% (10/12 present) | +-- | [5] Git Governance : .githooks active, RFC 2822 Assisted-by: trailer checked | +-- | [6] Quality Gates : Turnkey verify, Tagref, Linkcheck, CLOC active | +-- +-------------------------------------------------------------------------------+ +-- @ +-- +-- = Worked Example +-- +-- >>> let lang = LangHaskell +-- >>> languageName lang +-- "Haskell" +-- >>> let bld = BuildCabalProject +-- >>> buildSystemName bld +-- "Cabal Multi-Package Workspace (cabal.project)" +-- >>> let sev = SeverityCritical +-- >>> docSeverityName sev +-- "CRITICAL" +module Gachi.Retrofit.Types + ( -- * Programming Language Classification + Language(..) + , LanguageStats(..) + , languageName + + -- * Build Systems & Layout + , BuildSystem(..) + , WorkspaceLayout(..) + , buildSystemName + , layoutName + + -- * Test Infrastructure + , TestFramework(..) + , TestSuiteInfo(..) + , TestInfrastructure(..) + , testFrameworkName + + -- * Documentation Gaps & Categories + , DocCategory(..) + , DocSeverity(..) + , DocGap(..) + , docCategoryName + , docSeverityName + + -- * Git Governance & Hooks + , GitGovernanceStatus(..) + + -- * Physical Verification Harnesses + , VerificationHarnessStatus(..) + + -- * Comprehensive Diagnostic Report + , DiagnosticReport(..) + ) where + +import Data.Text (Text) + +-------------------------------------------------------------------------------- +-- 1. Programming Language Modeling +-------------------------------------------------------------------------------- + +-- | Recognized programming language families identified during repository inspection. +-- +-- Language classification is performed by inspecting source file extensions across +-- the workspace, excluding known build artifact directories (e.g. @dist-newstyle@, +-- @target@, @node_modules@, @.venv@). +data Language + = LangHaskell + -- ^ Haskell source code files (@.hs@, @.lhs@). Primary target for Gachi multi-package + -- workspace scaffolding, Cabal 3.18 / GHC 9.14 compiler stanzas, and HLint policies. + | LangRust + -- ^ Rust source code files (@.rs@). Target for Cargo workspace layouts, @rustfmt.toml@, + -- and clippy verification gates. + | LangC + -- ^ C source and header files (@.c@, @.h@). Target for Make, CMake, and @.clang-format@. + | LangCpp + -- ^ C++ source and header files (@.cpp@, @.cc@, @.cxx@, @.hpp@, @.hxx@). + | LangPython + -- ^ Python source code files (@.py@). Target for Poetry, Flit, and pytest. + | LangShell + -- ^ POSIX Shell / Bash / Zsh scripts (@.sh@, @.bash@, @.zsh@). Typical in @bin/@. + | LangOCaml + -- ^ OCaml source code files (@.ml@, @.mli@). + | LangGo + -- ^ Go source code files (@.go@). + | LangJava + -- ^ Java source code files (@.java@). + | LangJavaScript + -- ^ JavaScript source files (@.js@, @.mjs@, @.cjs@). + | LangTypeScript + -- ^ TypeScript source files (@.ts@, @.tsx@). + | LangOther !Text + -- ^ Other programming language identified by file extension. + deriving stock (Eq, Ord, Show) + +-- | Detailed file count and percentage metrics for a detected programming language. +-- +-- Summarizes the prevalence of a language across the scanned codebase. Used to +-- compute the 'diagPrimaryLanguage' and inform build toolchain selection. +data LanguageStats = LanguageStats + { langType :: !Language + -- ^ Classified language family. + , langFiles :: !Int + -- ^ Total number of matching source files discovered across the repository. + , langPercentage :: !Double + -- ^ Proportion of this language relative to total source files (0.0 to 100.0). + , langExtensions :: ![Text] + -- ^ Unique file extensions associated with this language detection (e.g. @[".hs", ".lhs"]@). + } deriving stock (Eq, Show) + +-- | Converts a 'Language' into its canonical human-readable display title. +-- +-- === Examples +-- +-- >>> languageName LangHaskell +-- "Haskell" +-- >>> languageName LangRust +-- "Rust" +-- >>> languageName (LangOther "Zig") +-- "Zig" +languageName :: Language -> Text +languageName LangHaskell = "Haskell" +languageName LangRust = "Rust" +languageName LangC = "C" +languageName LangCpp = "C++" +languageName LangPython = "Python" +languageName LangShell = "Shell / Bash" +languageName LangOCaml = "OCaml" +languageName LangGo = "Go" +languageName LangJava = "Java" +languageName LangJavaScript = "JavaScript" +languageName LangTypeScript = "TypeScript" +languageName (LangOther name) = name + +-------------------------------------------------------------------------------- +-- 2. Build Systems & Workspace Layout +-------------------------------------------------------------------------------- + +-- | Build system manifests and toolchains discovered in the target repository. +-- +-- Identifies declarative build manifests at the repository root and package subdirectories. +-- Informs the retrofitting engine whether a repository can be adopted directly or requires +-- multi-package scaffolding. +data BuildSystem + = BuildCabalProject + -- ^ Haskell Cabal multi-package workspace definition (@cabal.project@). + -- Indicates a modern Cabal workspace supporting cross-package dependencies. + | BuildCabalPackage + -- ^ Haskell Cabal single-package manifest (@*.cabal@ at repository root). + -- Indicates a legacy single-package repository or standalone library. + | BuildStack + -- ^ Haskell Stack build tool definition (@stack.yaml@). + | BuildHpack + -- ^ Haskell Hpack package generator (@package.yaml@). + | BuildCargo + -- ^ Rust Cargo workspace or package manifest (@Cargo.toml@). + | BuildCMake + -- ^ CMake build system definition (@CMakeLists.txt@). + | BuildMake + -- ^ Standard Makefile / GNUmakefile build system. + | BuildMeson + -- ^ Meson build definition (@meson.build@). + | BuildPoetry + -- ^ Python Poetry dependency configuration (@pyproject.toml@). + | BuildFlit + -- ^ Python Flit packaging manifest (@pyproject.toml@). + | BuildSetuptools + -- ^ Python Setuptools manifest (@setup.py@ / @setup.cfg@). + | BuildPip + -- ^ Python pip requirements file (@requirements.txt@). + | BuildNix + -- ^ Nix build expression or flake (@flake.nix@ / @default.nix@). + | BuildOther !Text + -- ^ Custom or unrecognized build configuration. + deriving stock (Eq, Ord, Show) + +-- | High-level architectural workspace layout of the target repository. +-- +-- Categorizes repository topography into canonical patterns to determine the appropriate +-- overlay strategy in Phase 4: +-- +-- * 'LayoutMultiPackage': Standard Gachi multi-package hierarchy (@packages/*/@). +-- * 'LayoutSinglePackage': Standalone single-package project with root manifest. +-- * 'LayoutPolyglot': Multi-language repository with multiple heterogeneous build tools. +-- * 'LayoutUnstructured': Raw source files without a recognizable build manifest. +data WorkspaceLayout + = LayoutSinglePackage + -- ^ Single package located at repository root (e.g. root @my-project.cabal@). + | LayoutMultiPackage + -- ^ Canonical multi-package layout with packages segregated in @packages/*/@. + | LayoutPolyglot + -- ^ Polyglot repository containing multiple heterogeneous build systems (e.g. Haskell + Rust). + | LayoutUnstructured + -- ^ Source files discovered without a recognized build manifest. + deriving stock (Eq, Ord, Show) + +-- | Converts a 'BuildSystem' into a descriptive string. +-- +-- === Examples +-- +-- >>> buildSystemName BuildCabalProject +-- "Cabal Multi-Package Workspace (cabal.project)" +-- >>> buildSystemName BuildCargo +-- "Cargo Package / Workspace (Cargo.toml)" +buildSystemName :: BuildSystem -> Text +buildSystemName BuildCabalProject = "Cabal Multi-Package Workspace (cabal.project)" +buildSystemName BuildCabalPackage = "Cabal Single-Package Manifest (*.cabal)" +buildSystemName BuildStack = "Stack Project Definition (stack.yaml)" +buildSystemName BuildHpack = "Hpack Package Specification (package.yaml)" +buildSystemName BuildCargo = "Cargo Package / Workspace (Cargo.toml)" +buildSystemName BuildCMake = "CMake Build Configuration (CMakeLists.txt)" +buildSystemName BuildMake = "GNU Make / POSIX Makefile (Makefile)" +buildSystemName BuildMeson = "Meson Build Definition (meson.build)" +buildSystemName BuildPoetry = "Python Poetry Project (pyproject.toml)" +buildSystemName BuildFlit = "Python Flit Package (pyproject.toml)" +buildSystemName BuildSetuptools = "Python Setuptools (setup.py)" +buildSystemName BuildPip = "Python Pip Requirements (requirements.txt)" +buildSystemName BuildNix = "Nix Build Expression (flake.nix / default.nix)" +buildSystemName (BuildOther desc) = desc + +-- | Converts a 'WorkspaceLayout' into a descriptive string. +-- +-- === Examples +-- +-- >>> layoutName LayoutMultiPackage +-- "Multi-Package Workspace Layout (packages/*)" +-- >>> layoutName LayoutSinglePackage +-- "Single-Package Root Layout" +layoutName :: WorkspaceLayout -> Text +layoutName LayoutSinglePackage = "Single-Package Root Layout" +layoutName LayoutMultiPackage = "Multi-Package Workspace Layout (packages/*)" +layoutName LayoutPolyglot = "Polyglot Multi-Toolchain Workspace" +layoutName LayoutUnstructured = "Unstructured Source Code Tree" + +-------------------------------------------------------------------------------- +-- 3. Test Infrastructure Modeling +-------------------------------------------------------------------------------- + +-- | Testing frameworks identified in repository manifests or source files. +-- +-- Introspects test imports and dependency manifests to determine the active testing +-- harness without executing arbitrary code. +data TestFramework + = FrameworkHspec + -- ^ Haskell Hspec BDD testing framework (@Test.Hspec@). + | FrameworkTasty + -- ^ Haskell Tasty test runner (@Test.Tasty@). + | FrameworkQuickCheck + -- ^ QuickCheck property-based testing (@Test.QuickCheck@). + | FrameworkHedgehog + -- ^ Hedgehog property testing library (@Hedgehog@). + | FrameworkCargoTest + -- ^ Built-in Rust test harness (@cargo test@ / @#[cfg(test)]@). + | FrameworkPytest + -- ^ Python pytest test framework (@pytest@). + | FrameworkUnittest + -- ^ Python standard unittest library (@unittest@). + | FrameworkCTest + -- ^ CTest / CMake test runner. + | FrameworkUnknown !Text + -- ^ Other test framework identifier. + deriving stock (Eq, Ord, Show) + +-- | Converts a 'TestFramework' into its canonical title. +-- +-- === Examples +-- +-- >>> testFrameworkName FrameworkHspec +-- "Hspec" +-- >>> testFrameworkName FrameworkTasty +-- "Tasty" +testFrameworkName :: TestFramework -> Text +testFrameworkName FrameworkHspec = "Hspec" +testFrameworkName FrameworkTasty = "Tasty" +testFrameworkName FrameworkQuickCheck = "QuickCheck" +testFrameworkName FrameworkHedgehog = "Hedgehog" +testFrameworkName FrameworkCargoTest = "Cargo Test" +testFrameworkName FrameworkPytest = "pytest" +testFrameworkName FrameworkUnittest = "unittest" +testFrameworkName FrameworkCTest = "CTest" +testFrameworkName (FrameworkUnknown txt) = txt + +-- | Information describing an identified test suite or test target. +-- +-- Records the declared test suite identifier, its primary entry point or test directory, +-- and all discovered test frameworks. +data TestSuiteInfo = TestSuiteInfo + { testSuiteName :: !Text + -- ^ Declared test suite name (e.g. @"tests"@, @"spec"@). + , testSuitePath :: !FilePath + -- ^ Primary entry point or test directory (e.g. @"test"@, @"test/Main.hs"@). + , testFrameworks :: ![TestFramework] + -- ^ Identified test framework dependencies. + } deriving stock (Eq, Show) + +-- | Aggregate test infrastructure status discovered during repository inspection. +-- +-- Assesses whether the repository contains verifiable test suites, counts test files, +-- and catalogs declared test targets. +data TestInfrastructure = TestInfrastructure + { hasTests :: !Bool + -- ^ True if test directories, manifests, or suites were found. + , testSuites :: ![TestSuiteInfo] + -- ^ Specific test suites discovered or declared. + , testDirectories :: ![FilePath] + -- ^ Existing test directories (e.g. @"test"@, @"tests"@, @"spec"@). + , testFileCount :: !Int + -- ^ Total number of test source files located. + } deriving stock (Eq, Show) + +-------------------------------------------------------------------------------- +-- 4. Documentation Gaps & Categories +-------------------------------------------------------------------------------- + +-- | Documentation category classifications per @DOC_STRATEGY.md@ §1. +-- +-- Classifies documentation into purpose-built genres serving three distinct audiences: +-- 1. __Arrivals:__ Newcomers seeking immediate orientation (@README.md@). +-- 2. __API Consumers:__ Developers looking for reference guides, types, and invariants. +-- 3. __Maintainers:__ Core contributors governing architectural decisions, notes, and roadmap. +-- 4. __AI Coding Assistants:__ Modular rules and bounded context projections (@AGENTS.md@). +data DocCategory + = DocOrientation + -- ^ Newcomer orientation, introductory facts, and project vision (@README.md@). + | DocCorpusInventory + -- ^ Curated inventory and reading paths per @DOC_STRATEGY.md@ §1 (@docs/INDEX.md@). + | DocDesignRationale + -- ^ Architectural decisions, trade-offs, and open questions (@docs/notes/*_DESIGN.md@). + | DocStrategy + -- ^ Corpus policies, lifecycle, precedence rules, and authority (@docs/notes/DOC_STRATEGY.md@). + | DocGovernance + -- ^ Strategic roadmaps and session frontiers (@PLAN.md@, @STATE.md@). + | DocOperational + -- ^ Maintenance manuals, gate triage, and release procedures (@docs/MAINTAINER_GUIDE.md@). + | DocTutorial + -- ^ Worked examples and newcomer tutorials (@docs/TUTORIAL.md@, @docs/NEWBIE_GUIDE.md@). + | DocAdvisory + -- ^ AI coding assistant advisories and modular rules (@AGENTS.md@, @.agents/rules/@). + | DocAttribution + -- ^ Commit trailer attribution policy per RFC 2822 (@docs/notes/COMMIT_ATTRIBUTION.md@). + | DocChangelog + -- ^ Release history, licensing terms, and code of conduct (@CHANGELOG.md@, @LICENSE@). + deriving stock (Eq, Ord, Show) + +-- | Severity level associated with a missing documentation asset. +-- +-- Prioritizes documentation remediation actions during retrofitting: +-- * 'SeverityCritical': Essential files without which repository cannot function cleanly. +-- * 'SeverityRecommended': Standard documentation practices required by @DOC_STRATEGY.md@. +-- * 'SeverityOptional': Contextual or supplementary documents. +data DocSeverity + = SeverityCritical + -- ^ Essential ecosystem document; retrofitting cannot succeed without it (e.g. @README.md@, @LICENSE@). + | SeverityRecommended + -- ^ Standard documentation practice per @DOC_STRATEGY.md@ (e.g. @PLAN.md@, @STATE.md@, @AGENTS.md@). + | SeverityOptional + -- ^ Nice-to-have or contextual document (e.g. @CLAUDE.md@, @CHANGELOG.md@). + deriving stock (Eq, Ord, Show) + +-- | Represents an individual documentation item audited against the canonical corpus. +-- +-- Evaluates presence on disk and provides actionable remediation guidance. +data DocGap = DocGap + { docPath :: !FilePath + -- ^ Relative file path of the documentation asset. + , docCategory :: !DocCategory + -- ^ Functional category of this document. + , docPresent :: !Bool + -- ^ True if the file physically exists on disk. + , docSeverity :: !DocSeverity + -- ^ Priority level of this document. + , docAdvice :: !Text + -- ^ Remediation guidance or explanation describing the document's purpose. + } deriving stock (Eq, Show) + +-- | Converts a 'DocCategory' into a human-readable title. +-- +-- === Examples +-- +-- >>> docCategoryName DocOrientation +-- "Arrivals & Orientation" +-- >>> docCategoryName DocDesignRationale +-- "Architecture & Rationale" +docCategoryName :: DocCategory -> Text +docCategoryName DocOrientation = "Arrivals & Orientation" +docCategoryName DocCorpusInventory = "Corpus Inventory" +docCategoryName DocDesignRationale = "Architecture & Rationale" +docCategoryName DocStrategy = "Documentation Policy" +docCategoryName DocGovernance = "Strategic Governance" +docCategoryName DocOperational = "Operational Guides" +docCategoryName DocTutorial = "Tutorial Track" +docCategoryName DocAdvisory = "Agent Advisory Layer" +docCategoryName DocAttribution = "Commit Attribution" +docCategoryName DocChangelog = "Changelog & Licensing" + +-- | Converts a 'DocSeverity' into a formatted status label. +-- +-- === Examples +-- +-- >>> docSeverityName SeverityCritical +-- "CRITICAL" +-- >>> docSeverityName SeverityRecommended +-- "RECOMMENDED" +docSeverityName :: DocSeverity -> Text +docSeverityName SeverityCritical = "CRITICAL" +docSeverityName SeverityRecommended = "RECOMMENDED" +docSeverityName SeverityOptional = "OPTIONAL" + +-------------------------------------------------------------------------------- +-- 5. Git Governance & Hook Conformance +-------------------------------------------------------------------------------- + +-- | Evaluation of Git repository configuration, hooks, and commit trailer enforcement. +-- +-- Inspects repository configuration to verify compliance with ecosystem standards: +-- * Dedicated hooks directory (@.githooks/@) configured via @git config core.hooksPath@. +-- * @commit-msg@ hook with POSIX executable permissions (+x) validating RFC 2822 @Assisted-by:@ trailers. +-- * @pre-commit@ hook enforcing Tagref and link integrity checks prior to commit recording. +-- * Standard commit template (@.gitmessage@) configured via @git config commit.template@. +data GitGovernanceStatus = GitGovernanceStatus + { hasGitRepo :: !Bool + -- ^ True if a valid @.git@ directory exists at the repository root. + , hasHooksDir :: !Bool + -- ^ True if a dedicated @.githooks@ directory exists. + , hooksPathConfig :: !(Maybe Text) + -- ^ Value of @git config core.hooksPath@ if explicitly configured. + , hasCommitMsgHook :: !Bool + -- ^ True if @commit-msg@ hook exists. + , isCommitMsgExecutable :: !Bool + -- ^ True if @commit-msg@ has POSIX executable permission (+x). + , hasCommitMsgAttributionCheck :: !Bool + -- ^ True if @commit-msg@ validates Sarutahiko / RFC 2822 @Assisted-by:@ trailers. + , hasPreCommitHook :: !Bool + -- ^ True if @pre-commit@ hook exists. + , isPreCommitExecutable :: !Bool + -- ^ True if @pre-commit@ has POSIX executable permission (+x). + , hasGitMessageTemplate :: !Bool + -- ^ True if @.gitmessage@ template file exists. + , gitMessageConfig :: !(Maybe Text) + -- ^ Value of @git config commit.template@ if explicitly configured. + } deriving stock (Eq, Show) + +-------------------------------------------------------------------------------- +-- 6. Physical Verification Harnesses +-------------------------------------------------------------------------------- + +-- | Evaluation of physical verification scripts, linters, and quality gates. +-- +-- Assesses presence and executability of the turnkey 5-gate verification suite: +-- 1. Turnkey verification runner (@bin/-verify@). +-- 2. Tagref cross-reference configuration (@tagref.yml@) and runner (@bin/-tagref@). +-- 3. Markdown link & anchor integrity checker (@bin/-linkcheck@). +-- 4. In-code comment density audit harness (@bin/-cloc@). +-- 5. Static linter configurations (@.hlint.yaml@, @fourmolu.yaml@). +data VerificationHarnessStatus = VerificationHarnessStatus + { hasVerifyScript :: !Bool + -- ^ True if a turnkey verification script (e.g. @bin/*-verify@) exists. + , verifyScriptPath :: !(Maybe FilePath) + -- ^ Relative file path of the primary verification runner if found. + , hasTagrefConfig :: !Bool + -- ^ True if @tagref.yml@ or @.tagref@ exists. + , hasTagrefHarness :: !Bool + -- ^ True if @bin/*-tagref@ runner script exists. + , hasLinkcheckHarness :: !Bool + -- ^ True if @bin/*-linkcheck@ runner script exists. + , hasClocHarness :: !Bool + -- ^ True if @bin/*-cloc@ comment density runner script exists. + , hasHlintConfig :: !Bool + -- ^ True if @.hlint.yaml@ linter configuration exists. + , hasFourmoluConfig :: !Bool + -- ^ True if @fourmolu.yaml@ code formatter configuration exists. + } deriving stock (Eq, Show) + +-------------------------------------------------------------------------------- +-- 7. Comprehensive Diagnostic Report +-------------------------------------------------------------------------------- + +-- | The unified diagnostic evaluation report produced by inspecting a target codebase. +-- +-- Combines language statistics, build systems, test infrastructure, documentation gaps, +-- git governance, verification harness status, and computes a quantitative retrofit score. +-- +-- Per Note [Non-Destructive Skeleton Overlay] [ref:note-nondestructive-retrofit], +-- generating this report is strictly observational and non-destructive. +data DiagnosticReport = DiagnosticReport + { diagTargetDir :: !FilePath + -- ^ Inspected target directory path. + , diagProjectName :: !Text + -- ^ Inferred or detected project identifier. + , diagPrimaryLanguage :: !(Maybe Language) + -- ^ Dominant programming language identified. + , diagLanguages :: ![LanguageStats] + -- ^ Complete breakdown of all detected programming languages. + , diagBuildSystems :: ![BuildSystem] + -- ^ All build manifests discovered. + , diagLayout :: !WorkspaceLayout + -- ^ Classified repository workspace topology. + , diagDiscoveredPackages :: ![Text] + -- ^ List of package names discovered across the codebase. + , diagTestInfra :: !TestInfrastructure + -- ^ Status of test directories, declarations, and frameworks. + , diagDocGaps :: ![DocGap] + -- ^ Detailed inventory of documentation gaps against @DOC_STRATEGY.md@. + , diagDocCompliancePct :: !Double + -- ^ Percentage of required and recommended documents present (0.0 to 100.0). + , diagGitGovernance :: !GitGovernanceStatus + -- ^ Status of Git hooks, attribution trailers, and commit templates. + , diagVerificationHarness :: !VerificationHarnessStatus + -- ^ Status of 5-gate physical verification infrastructure. + , diagRetrofitScore :: !Double + -- ^ Overall weighted ecosystem retrofit readiness score (0.0 to 100.0). + , diagRemediationPlan :: ![Text] + -- ^ Prioritized list of actionable remediation steps for Phase 4. + } deriving stock (Eq, Show) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,478 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Module: Main +-- Description: Comprehensive test suite for gachi-retrofit (Milestone 4.1) +module Main (main) where + +import Control.Exception (SomeException, catch) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + , getPermissions + , removeDirectoryRecursive + , setOwnerExecutable + , setPermissions + ) +import System.FilePath (takeDirectory, ()) +import Test.Hspec + +import Gachi.Retrofit +import Gachi.Schema.Project (Author(..), defaultProject) + +main :: IO () +main = hspec $ do + describe "Gachi.Retrofit.Diagnostic (Pure Analyzers)" $ do + it "detects programming language distribution and file percentages" $ do + let samplePaths = + [ "src/Foo.hs" + , "src/Bar.hs" + , "src/Baz.lhs" + , "native/core.rs" + , "script/run.py" + , "bin/tool.sh" + ] + stats = detectLanguages samplePaths + length stats `shouldBe` 4 + case stats of + (top:rest) -> do + langType top `shouldBe` LangHaskell + langFiles top `shouldBe` 3 + langPercentage top `shouldBe` 50.0 + map langType rest `shouldMatchList` [LangRust, LangPython, LangShell] + [] -> expectationFailure "Expected language statistics to be non-empty" + + it "handles empty or unrecognized file lists gracefully" $ do + detectLanguages [] `shouldBe` [] + detectLanguages ["data.txt", "image.png"] `shouldBe` [] + + it "classifies single-package and multi-package workspace layouts" $ do + let singlePaths = ["my-proj.cabal", "src/Main.hs", "README.md"] + (buildsSingle, layoutSingle) = detectBuildSystems "." singlePaths + BuildCabalPackage `elem` buildsSingle `shouldBe` True + layoutSingle `shouldBe` LayoutSinglePackage + + let multiPaths = + [ "cabal.project" + , "packages/core/core.cabal" + , "packages/cli/cli.cabal" + ] + (buildsMulti, layoutMulti) = detectBuildSystems "." multiPaths + BuildCabalProject `elem` buildsMulti `shouldBe` True + BuildCabalPackage `elem` buildsMulti `shouldBe` True + layoutMulti `shouldBe` LayoutMultiPackage + + it "identifies polyglot and foreign build manifests" $ do + let polyPaths = + [ "cabal.project" + , "Cargo.toml" + , "CMakeLists.txt" + , "Makefile" + , "pyproject.toml" + ] + (builds, layout) = detectBuildSystems "." polyPaths + BuildCargo `elem` builds `shouldBe` True + BuildCMake `elem` builds `shouldBe` True + BuildMake `elem` builds `shouldBe` True + BuildPoetry `elem` builds `shouldBe` True + layout `shouldBe` LayoutPolyglot + + it "audits documentation gaps against DOC_STRATEGY.md requirements" $ do + let sparsePaths = ["README.md", "LICENSE"] + gaps = detectDocumentationGaps "." sparsePaths + present = filter docPresent gaps + missing = filter (not . docPresent) gaps + + length present `shouldBe` 2 + map docPath present `shouldMatchList` ["README.md", "LICENSE"] + + let missingCritical = filter (\d -> docSeverity d == SeverityCritical) missing + missingCritical `shouldBe` [] + + let missingRecommended = filter (\d -> docSeverity d == SeverityRecommended) missing + any (\d -> docPath d == "PLAN.md") missingRecommended `shouldBe` True + any (\d -> docPath d == "STATE.md") missingRecommended `shouldBe` True + any (\d -> docPath d == "AGENTS.md") missingRecommended `shouldBe` True + any (\d -> docPath d == "docs/INDEX.md") missingRecommended `shouldBe` True + + it "computes weighted ecosystem retrofit readiness score" $ do + let noStats = [] + noBuilds = [] + noTests = TestInfrastructure False [] [] 0 + allDocsMissing = detectDocumentationGaps "." [] + noGit = GitGovernanceStatus False False Nothing False False False False False False Nothing + noHarness = VerificationHarnessStatus False Nothing False False False False False False + + scoreLow = computeRetrofitScore noStats noBuilds noTests allDocsMissing noGit noHarness + scoreLow `shouldSatisfy` (< 30.0) + + let sampleStats = [LanguageStats LangHaskell 10 100.0 [".hs"]] + sampleBuilds = [BuildCabalProject, BuildCabalPackage] + sampleTests = TestInfrastructure True [TestSuiteInfo "tests" "test" [FrameworkHspec]] ["test"] 5 + allDocsPresent = map (\d -> d { docPresent = True }) allDocsMissing + sampleGit = GitGovernanceStatus True True (Just ".githooks") True True True True True True (Just ".gitmessage") + sampleHarness = VerificationHarnessStatus True (Just "bin/verify") True True True True True True + + scoreHigh = computeRetrofitScore sampleStats sampleBuilds sampleTests allDocsPresent sampleGit sampleHarness + scoreHigh `shouldSatisfy` (>= 90.0) + + it "generates prioritized remediation actions" $ do + let noTests = TestInfrastructure False [] [] 0 + gaps = detectDocumentationGaps "." [] + noGit = GitGovernanceStatus False False Nothing False False False False False False Nothing + noHarness = VerificationHarnessStatus False Nothing False False False False False False + plan = computeRemediationPlan "victim" LayoutSinglePackage noTests gaps noGit noHarness + + any ("Initialize Git repository" `T.isInfixOf`) plan `shouldBe` True + any ("bin/victim-verify" `T.isInfixOf`) plan `shouldBe` True + any ("Scaffold mandatory document: README.md" `T.isInfixOf`) plan `shouldBe` True + any ("Establish baseline test suite" `T.isInfixOf`) plan `shouldBe` True + any ("Consider migrating from single-package layout" `T.isInfixOf`) plan `shouldBe` True + + describe "Gachi.Retrofit.Report (Pretty-Printing & Formats)" $ do + it "renders aligned terminal ASCII dashboard with all sections" $ do + let sampleReport = DiagnosticReport + { diagTargetDir = "/tmp/sample-repo" + , diagProjectName = "sample-repo" + , diagPrimaryLanguage = Just LangHaskell + , diagLanguages = [LanguageStats LangHaskell 10 100.0 [".hs"]] + , diagBuildSystems = [BuildCabalProject] + , diagLayout = LayoutMultiPackage + , diagDiscoveredPackages = ["pkg-core", "pkg-cli"] + , diagTestInfra = TestInfrastructure True [TestSuiteInfo "test" "test" [FrameworkHspec]] ["test"] 3 + , diagDocGaps = detectDocumentationGaps "." ["README.md"] + , diagDocCompliancePct = 10.0 + , diagGitGovernance = GitGovernanceStatus True True (Just ".githooks") True True True True True True (Just ".gitmessage") + , diagVerificationHarness = VerificationHarnessStatus True (Just "bin/sample-verify") True True True True True True + , diagRetrofitScore = 75.5 + , diagRemediationPlan = ["Scaffold mandatory document: LICENSE"] + } + output = formatDiagnosticReport sampleReport + + "Gachi Diagnostic Repository Inspector" `T.isInfixOf` output `shouldBe` True + "sample-repo" `T.isInfixOf` output `shouldBe` True + "75.5%" `T.isInfixOf` output `shouldBe` True + "[1] Programming Language Breakdown" `T.isInfixOf` output `shouldBe` True + "[2] Test Infrastructure" `T.isInfixOf` output `shouldBe` True + "[3] Documentation Inventory" `T.isInfixOf` output `shouldBe` True + "[4] Git Governance & Commit Attribution" `T.isInfixOf` output `shouldBe` True + "[5] Physical Verification Harnesses & Quality Gates" `T.isInfixOf` output `shouldBe` True + "[6] Prioritized Phase 4 Remediation Plan" `T.isInfixOf` output `shouldBe` True + + it "renders GitHub-Flavored Markdown report" $ do + let sampleReport = DiagnosticReport + { diagTargetDir = "/tmp/sample-repo" + , diagProjectName = "sample-repo" + , diagPrimaryLanguage = Just LangHaskell + , diagLanguages = [LanguageStats LangHaskell 10 100.0 [".hs"]] + , diagBuildSystems = [BuildCabalPackage] + , diagLayout = LayoutSinglePackage + , diagDiscoveredPackages = ["sample-repo"] + , diagTestInfra = TestInfrastructure False [] [] 0 + , diagDocGaps = detectDocumentationGaps "." [] + , diagDocCompliancePct = 0.0 + , diagGitGovernance = GitGovernanceStatus False False Nothing False False False False False False Nothing + , diagVerificationHarness = VerificationHarnessStatus False Nothing False False False False False False + , diagRetrofitScore = 25.0 + , diagRemediationPlan = ["Initialize Git repository"] + } + md = formatDiagnosticMarkdown sampleReport + + "# Diagnostic Repository Inspection Report: `sample-repo`" `T.isInfixOf` md `shouldBe` True + "| Language | Files | Share | Extensions |" `T.isInfixOf` md `shouldBe` True + "| Haskell | 10 | 100.0% |" `T.isInfixOf` md `shouldBe` True + + it "renders compact single-line summary string" $ do + let sampleReport = DiagnosticReport + { diagTargetDir = "/tmp/sample" + , diagProjectName = "sample" + , diagPrimaryLanguage = Just LangHaskell + , diagLanguages = [] + , diagBuildSystems = [] + , diagLayout = LayoutSinglePackage + , diagDiscoveredPackages = [] + , diagTestInfra = TestInfrastructure False [] [] 0 + , diagDocGaps = [] + , diagDocCompliancePct = 0.0 + , diagGitGovernance = GitGovernanceStatus False False Nothing False False False False False False Nothing + , diagVerificationHarness = VerificationHarnessStatus False Nothing False False False False False False + , diagRetrofitScore = 40.0 + , diagRemediationPlan = [] + } + line = formatDiagnosticSummaryLine sampleReport + "gachi retrofit inspect [sample]: Haskell, Single-Package Root Layout, Score: 40.0%" `T.isInfixOf` line `shouldBe` True + + describe "Gachi.Retrofit (Filesystem Inspection)" $ do + it "scans a mock legacy repository and identifies architectural attributes" $ do + let tmpDir = "/tmp/gachi-test-legacy-victim" + removeDirectoryRecursive tmpDir `catch` (\(_ :: SomeException) -> pure ()) + createDirectoryIfMissing True (tmpDir "src") + createDirectoryIfMissing True (tmpDir "test") + + TIO.writeFile (tmpDir "victim.cabal") "name: victim\nversion: 0.1.0.0\n" + TIO.writeFile (tmpDir "src" "Victim.hs") "module Victim where\nx = 42\n" + TIO.writeFile (tmpDir "test" "Spec.hs") "import Test.Hspec\nmain = hspec (it \"works\" $ True `shouldBe` True)\n" + TIO.writeFile (tmpDir "README.md") "# Victim Project\n" + + report <- scanRepository tmpDir + + diagProjectName report `shouldBe` "victim" + diagPrimaryLanguage report `shouldBe` Just LangHaskell + diagLayout report `shouldBe` LayoutSinglePackage + hasTests (diagTestInfra report) `shouldBe` True + diagDocCompliancePct report `shouldSatisfy` (> 0.0) + hasGitRepo (diagGitGovernance report) `shouldBe` False + hasVerifyScript (diagVerificationHarness report) `shouldBe` False + + -- Clean up + removeDirectoryRecursive tmpDir `catch` (\(_ :: SomeException) -> pure ()) + + it "executes self-diagnostic scan on the host workspace with high conformance" $ do + cwd <- getCurrentDirectory + repoRoot <- findRepoRoot cwd + report <- scanRepository repoRoot + + diagProjectName report `shouldBe` "gachi" + diagPrimaryLanguage report `shouldBe` Just LangHaskell + diagLayout report `shouldBe` LayoutMultiPackage + diagBuildSystems report `shouldContain` [BuildCabalProject] + hasTests (diagTestInfra report) `shouldBe` True + hasGitRepo (diagGitGovernance report) `shouldBe` True + hasHooksDir (diagGitGovernance report) `shouldBe` True + hasCommitMsgHook (diagGitGovernance report) `shouldBe` True + hasCommitMsgAttributionCheck (diagGitGovernance report) `shouldBe` True + hasVerifyScript (diagVerificationHarness report) `shouldBe` True + diagRetrofitScore report `shouldSatisfy` (>= 90.0) + + describe "Gachi.Retrofit.Overlay (Non-Destructive Skeleton Overlay)" $ do + it "synthesizes complete candidate overlay assets across all 6 categories" $ do + let proj = defaultProject "sample" (Author "Test Author" "author@example.com") + candidates = synthesizeOverlayCandidates proj LayoutSinglePackage + length candidates `shouldSatisfy` (>= 25) + let paths = map actionPath candidates + all (`elem` paths) ["docs/INDEX.md", "docs/notes/DOC_STRATEGY.md", "PLAN.md", "STATE.md"] `shouldBe` True + all (`elem` paths) ["AGENTS.md", "CLAUDE.md", ".agents/rules/commit-attribution.md"] `shouldBe` True + all (`elem` paths) [".githooks/commit-msg", ".githooks/pre-commit", ".gitmessage"] `shouldBe` True + all (`elem` paths) ["bin/sample-verify", "bin/sample-tagref", "bin/sample-linkcheck", "bin/sample-cloc"] `shouldBe` True + all (`elem` paths) [".hlint.yaml", "fourmolu.yaml"] `shouldBe` True + + it "computes overlay plan preserving existing files and proposing missing assets" $ do + let tmpDir = "/tmp/gachi-test-overlay-plan" + removeDirectoryRecursive tmpDir `catch` (\(_ :: SomeException) -> pure ()) + createDirectoryIfMissing True (tmpDir "src") + TIO.writeFile (tmpDir "README.md") "# Existing README\n" + TIO.writeFile (tmpDir "src" "Main.hs") "module Main where\nmain = putStrLn \"hello\"\n" + + report <- scanRepository tmpDir + plan <- computeOverlayPlan tmpDir report + + planCreatedCount plan `shouldSatisfy` (> 0) + planPreservedCount plan `shouldSatisfy` (>= 1) + + let readmeAction = filter (\a -> actionPath a == "README.md") (planActions plan) + case readmeAction of + (act:_) -> actionType act `shouldBe` ActionPreserve + [] -> expectationFailure "Expected README.md to be present in overlay actions" + + -- Verify Git governance proposal + any (\case GitInitRepo -> True; _ -> False) (planGitActions plan) `shouldBe` True + any (\case GitSetConfig k _ -> k == "core.hooksPath"; _ -> False) (planGitActions plan) `shouldBe` True + + removeDirectoryRecursive tmpDir `catch` (\(_ :: SomeException) -> pure ()) + + it "executes non-destructive overlay, creates harnesses, configures git, and guarantees idempotency" $ do + let tmpDir = "/tmp/gachi-test-overlay-exec" + removeDirectoryRecursive tmpDir `catch` (\(_ :: SomeException) -> pure ()) + createDirectoryIfMissing True (tmpDir "src") + let origDomainCode = "module Domain where\nsecret = 1337\n" + TIO.writeFile (tmpDir "src" "Domain.hs") origDomainCode + TIO.writeFile (tmpDir "README.md") "# Original Title\n" + + report <- scanRepository tmpDir + plan <- computeOverlayPlan tmpDir report + res <- executeOverlayPlan plan + + resultSuccess res `shouldBe` True + all (`elem` resultCreatedFiles res) ["docs/INDEX.md", "AGENTS.md", ".githooks/commit-msg"] `shouldBe` True + "README.md" `elem` resultPreservedFiles res `shouldBe` True + + -- Invariant 1: Domain source code must remain 100% byte-identical + domainCodeAfter <- TIO.readFile (tmpDir "src" "Domain.hs") + domainCodeAfter `shouldBe` origDomainCode + + -- Invariant 2: Existing README.md preserved intact + readmeAfter <- TIO.readFile (tmpDir "README.md") + readmeAfter `shouldBe` "# Original Title\n" + + -- Invariant 3: Verification harnesses created with executable permissions + doesFileExist (tmpDir "bin" (T.unpack (diagProjectName report) ++ "-verify")) `shouldReturn` True + doesFileExist (tmpDir ".githooks" "commit-msg") `shouldReturn` True + + -- Invariant 4: Git repository initialized and configured + doesDirectoryExist (tmpDir ".git") `shouldReturn` True + + -- Invariant 5: Idempotency guarantee: Re-planning over retrofitted directory plans 0 creations for those assets + report2 <- scanRepository tmpDir + plan2 <- computeOverlayPlan tmpDir report2 + planCreatedCount plan2 `shouldBe` 0 + + removeDirectoryRecursive tmpDir `catch` (\(_ :: SomeException) -> pure ()) + + it "formats overlay plan and results into human-readable ASCII and Markdown dashboards" $ do + let tmpDir = "/tmp/gachi-test-overlay-fmt" + createDirectoryIfMissing True tmpDir + report <- scanRepository tmpDir + plan <- computeOverlayPlan tmpDir report + + let asciiPlan = formatOverlayPlan plan + "Gachi Non-Destructive Skeleton Overlay Plan" `T.isInfixOf` asciiPlan `shouldBe` True + "Proposed Actions:" `T.isInfixOf` asciiPlan `shouldBe` True + + let mdPlan = formatOverlayPlanMarkdown plan + "# Non-Destructive Skeleton Overlay Plan:" `T.isInfixOf` mdPlan `shouldBe` True + "| Status | File Path | Executable |" `T.isInfixOf` mdPlan `shouldBe` True + + res <- executeOverlayPlan plan + let asciiRes = formatOverlayResult res + "Gachi Non-Destructive Overlay Execution Results" `T.isInfixOf` asciiRes `shouldBe` True + "Overlay successfully applied!" `T.isInfixOf` asciiRes `shouldBe` True + + removeDirectoryRecursive tmpDir `catch` (\(_ :: SomeException) -> pure ()) + + describe "Gachi.Retrofit.QualityGate (Progressive Quality Gates)" $ do + it "constructs pure gate specifications across all four progressive levels (L0-L3)" $ do + length level0Gates `shouldBe` 8 + length level1Gates `shouldBe` 2 + length level2Gates `shouldBe` 1 + length level3Gates `shouldBe` 3 + length allLevelGates `shouldBe` 14 + all (\g -> gateLevel g == QualityLevel0) level0Gates `shouldBe` True + all (\g -> gateLevel g == QualityLevel1) level1Gates `shouldBe` True + all (\g -> gateLevel g == QualityLevel2) level2Gates `shouldBe` True + all (\g -> gateLevel g == QualityLevel3) level3Gates `shouldBe` True + + it "evaluates monotonic compliance progression via computeAchievedLevel" $ do + let mkRes gName lvl passed = GateResult (GateCheck gName lvl "desc" (\_ -> pure passed)) passed "detail" + allPass = [ mkRes "g0" QualityLevel0 True + , mkRes "g1" QualityLevel1 True + , mkRes "g2" QualityLevel2 True + , mkRes "g3" QualityLevel3 True + ] + computeAchievedLevel allPass `shouldBe` QualityLevel3 + + let failL3 = [ mkRes "g0" QualityLevel0 True + , mkRes "g1" QualityLevel1 True + , mkRes "g2" QualityLevel2 True + , mkRes "g3" QualityLevel3 False + ] + computeAchievedLevel failL3 `shouldBe` QualityLevel2 + + let failL2 = [ mkRes "g0" QualityLevel0 True + , mkRes "g1" QualityLevel1 True + , mkRes "g2" QualityLevel2 False + , mkRes "g3" QualityLevel3 True + ] + computeAchievedLevel failL2 `shouldBe` QualityLevel1 + + let failL1 = [ mkRes "g0" QualityLevel0 True + , mkRes "g1" QualityLevel1 False + , mkRes "g2" QualityLevel2 True + , mkRes "g3" QualityLevel3 True + ] + computeAchievedLevel failL1 `shouldBe` QualityLevel0 + + let failL0 = [ mkRes "g0" QualityLevel0 False + , mkRes "g1" QualityLevel1 True + , mkRes "g2" QualityLevel2 True + , mkRes "g3" QualityLevel3 True + ] + computeAchievedLevel failL0 `shouldBe` QualityLevel0 + + it "generates prioritized remediation steps ordered by progressive levels" $ do + let mkRes gName lvl passed = GateResult (GateCheck gName lvl "desc" (\_ -> pure passed)) passed "detail" + mixed = [ mkRes "Git Hooks Directory" QualityLevel0 False + , mkRes "Tagref Cross-Reference" QualityLevel1 False + , mkRes "Cabal Build Clean" QualityLevel2 False + , mkRes "HLint Zero Hints" QualityLevel3 False + ] + steps = computeRemediationSteps mixed + length steps `shouldBe` 4 + map stepPriority steps `shouldBe` [PriorityFoundation, PriorityStructural, PriorityCompiler, PriorityAnalysis] + any (\s -> "gachi retrofit" `T.isInfixOf` stepCommand s) steps `shouldBe` True + any (\s -> "tagref" `T.isInfixOf` stepCommand s) steps `shouldBe` True + any (\s -> "cabal build" `T.isInfixOf` stepCommand s) steps `shouldBe` True + any (\s -> "hlint" `T.isInfixOf` stepCommand s) steps `shouldBe` True + + it "formats terminal ASCII dashboard and GitHub-Flavored Markdown reports" $ do + let mkRes gName lvl passed = GateResult (GateCheck gName lvl "desc" (\_ -> pure passed)) passed "detail" + results = [ mkRes "Git Repo" QualityLevel0 True + , mkRes "Hooks" QualityLevel0 False + , mkRes "Tagref" QualityLevel1 True + ] + report = QualityGateReport + { qgTargetDir = "/tmp/sample-project" + , qgProjectName = "sample-project" + , qgGateResults = results + , qgAchievedLevel = QualityLevel0 + , qgMaxPossibleLevel = QualityLevel3 + , qgPassedCount = 2 + , qgFailedCount = 1 + , qgRemediationSteps = computeRemediationSteps results + } + asciiOut = formatQualityGateReport report + mdOut = formatQualityGateMarkdown report + + "Gachi Progressive Quality Gate Report" `T.isInfixOf` asciiOut `shouldBe` True + "Target Directory: /tmp/sample-project" `T.isInfixOf` asciiOut `shouldBe` True + "[Level 0: Foundation]" `T.isInfixOf` asciiOut `shouldBe` True + "Remediation Plan" `T.isInfixOf` asciiOut `shouldBe` True + + "# Progressive Quality Gate Report: `sample-project`" `T.isInfixOf` mdOut `shouldBe` True + "| Status | Gate | Description |" `T.isInfixOf` mdOut `shouldBe` True + "## Level 0: Foundation" `T.isInfixOf` mdOut `shouldBe` True + + it "evaluates quality gates against a live retrofitted workspace" $ do + let tmpDir = "/tmp/gachi-test-quality-gate-live" + removeDirectoryRecursive tmpDir `catch` (\(_ :: SomeException) -> pure ()) + createDirectoryIfMissing True (tmpDir "bin") + createDirectoryIfMissing True (tmpDir ".githooks") + createDirectoryIfMissing True (tmpDir ".git") + createDirectoryIfMissing True (tmpDir "src") + + TIO.writeFile (tmpDir "README.md") "# Test Project\n" + TIO.writeFile (tmpDir "PLAN.md") "# Strategic Plan\n" + TIO.writeFile (tmpDir "tagref.yml") "archive: false\n" + TIO.writeFile (tmpDir ".hlint.yaml") "- ignore: {}\n" + TIO.writeFile (tmpDir ".gitmessage") "Subject\n" + TIO.writeFile (tmpDir ".githooks" "commit-msg") "#!/bin/sh\nexit 0\n" + TIO.writeFile (tmpDir ".githooks" "pre-commit") "#!/bin/sh\nexit 0\n" + TIO.writeFile (tmpDir "bin" "test-verify") "#!/bin/sh\nexit 0\n" + TIO.writeFile (tmpDir "src" "Main.hs") "module Main where\nmain = pure ()\n" + + -- Make scripts executable + perms <- getPermissions (tmpDir "bin" "test-verify") + setPermissions (tmpDir "bin" "test-verify") (setOwnerExecutable True perms) + + report <- evaluateQualityGates tmpDir + qgProjectName report `shouldSatisfy` (not . T.null) + qgPassedCount report `shouldSatisfy` (>= 8) + length (qgGateResults report) `shouldBe` 14 + + removeDirectoryRecursive tmpDir `catch` (\(_ :: SomeException) -> pure ()) + +findRepoRoot :: FilePath -> IO FilePath +findRepoRoot dir = do + hasProj <- doesFileExist (dir "cabal.project") + if hasProj + then pure dir + else do + let parent = takeDirectory dir + if parent == dir + then pure dir + else findRepoRoot parent +