diff --git a/gachi-schema.cabal b/gachi-schema.cabal new file mode 100644 --- /dev/null +++ b/gachi-schema.cabal @@ -0,0 +1,46 @@ +cabal-version: 3.0 +name: gachi-schema +version: 0.1.0.0 +synopsis: Declarative Dhall schemas and polytropos-dhall deserializers for Gachi +license: EUPL-1.2 +author: Nadia Yvette Chambers +maintainer: nadia.yvette.chambers@ik.me +build-type: Simple +tested-with: + GHC == 9.10.3, + GHC == 9.12.4, + GHC == 9.14.1 + +library + exposed-modules: + Gachi.Schema + Gachi.Schema.Project + Gachi.Schema.Dhall + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -Wcompat -Wredundant-constraints + build-depends: + base >= 4.14 && < 5, + gachi-core >= 0.1 && < 0.2, + polytropos-core >= 0.1 && < 0.2, + polytropos-dhall >= 0.1 && < 0.2, + dhall >= 1.42 && < 1.43, + text >= 2.0, + containers >= 0.6 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >= 4.14 && < 5, + gachi-core, + gachi-schema, + polytropos-core, + polytropos-dhall, + dhall, + text >= 2.0, + containers >= 0.6, + hspec >= 2.10 diff --git a/src/Gachi/Schema.hs b/src/Gachi/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Schema.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +-- | Module: Gachi.Schema +-- Description: Declarative project schemas, Dhall codecs, and open row representations +-- +-- Front door module for the @gachi-schema@ package. +-- +-- Provides strongly-typed project manifests ('Project', 'PackageSpec', 'Author', 'RemoteSpec'), +-- Dhall deserialization engines, pretty-printers, and open row isomorphisms ('ProjectRec') +-- powered by "Polytropos.Dhall". +-- +-- = Architectural Overview +-- +-- In the Gachi architecture, all project instantiation (@gachi init@), cross-repository +-- standardization (@gachi sync@), and retrofitting (@gachi retrofit@) operate on total, +-- deterministic Dhall schemas rather than untyped string templating (Jinja/Mustache). +-- +-- Schemas are decoded through 'Polytropos.Dhall' into either nominal records or open +-- heterogeneous rows without intermediate binary tree allocations. +-- +-- = When to Use This Module +-- +-- * Importing all project schema types and Dhall decoders with a single module import. +-- * Authoring or validating @project.dhall@ configurations. +-- * Converting between nominal project configurations and open row representations. +-- +-- = Worked Example +-- +-- >>> import Gachi.Schema +-- >>> proj <- decodeProjectText exampleProjectDhall +-- >>> projectName proj +-- "gongju" +-- >>> projectLicense proj +-- "EUPL-1.2" +module Gachi.Schema + ( -- * Note Architecture + -- $notes + + -- * Nominal Schema Types + Project(..) + , Author(..) + , PackageSpec(..) + , RemoteSpec(..) + + -- * Projection Selectors + , projectName + , projectDescription + , projectLicense + , projectAuthor + , projectGhcVersion + , projectCabalVersion + , projectPackages + , projectRemotes + , authorName + , authorEmail + , packageName + , packageSynopsis + , packageExposes + , remoteName + , remoteUrl + + -- * Open Row Types & Isomorphisms + , ProjectRow + , ProjectRec + , toProjectRec + , fromProjectRec + + , AuthorRow + , AuthorRec + , toAuthorRec + , fromAuthorRec + + , PackageRow + , PackageRec + , toPackageRec + , fromPackageRec + + , RemoteRow + , RemoteRec + , toRemoteRec + , fromRemoteRec + + -- * Dhall Evaluation & Serialization + , decodeProjectText + , decodeProjectFile + , decodeProjectEither + , decodeProjectRecText + , decodeProjectRecEither + , renderProjectDhall + , renderProjectRecDhall + + -- * Turnkey Schemas & Canonical Defaults + , projectSchemaDhall + , exampleProjectDhall + , defaultProject + , defaultPackage + , canonicalLicense + , canonicalGhcVersion + , canonicalCabalVersion + ) where + +import Gachi.Schema.Project +import Gachi.Schema.Dhall + +{- $notes +See Note [Dhall Parameterized Skeleton Templating] [ref:note-dhall-skeleton-templating]. +-} + +{- Note [Dhall Parameterized Skeleton Templating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +[tag:note-dhall-skeleton-templating] +All project templates, multi-package layouts, and tooling manifests in Gachi are defined +as total, strongly typed Dhall schemas decoded into osteological structures. + +Architectural Rationale: + 1. Determinism and Totality: Dhall expressions are guaranteed to terminate (strongly + normalizing) and have zero access to ambient system calls, filesystems, or networks + during evaluation. This ensures template evaluation is hermetic and reproducible. + 2. Strongly-Typed Schemas: Project metadata ('Project', 'PackageSpec', 'Author', 'RemoteSpec') + is validated at evaluation time before directory creation, preventing partial or corrupt + scaffolding runs. + 3. Seamless Generic & Row Decoding: By leveraging 'polytropos-dhall', schemas can be decoded + either into nominal Haskell records via 'GenericDhall' or into open heterogeneous records + ('Record') without intermediate AST tree allocations. + 4. Non-Destructive Extensibility: Schemas can provide default records, allowing user + overrides for specific fields without breaking backward compatibility when new metadata + fields are introduced. + +See also: + - Note [Ecosystem Standardization Invariants] [ref:note-ecosystem-standardization] +-} diff --git a/src/Gachi/Schema/Dhall.hs b/src/Gachi/Schema/Dhall.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Schema/Dhall.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Module: Gachi.Schema.Dhall +-- Description: Dhall schema definitions, encoders, decoders, and templates +-- +-- Provides turnkey encoders, decoders, and template definitions for evaluating +-- declarative Dhall project specifications into strongly typed 'Project' and 'ProjectRec' +-- structures. +-- +-- All decoding operations enforce the totality and safety guarantees established in +-- Note [Dhall Parameterized Skeleton Templating] [ref:note-dhall-skeleton-templating]. +-- +-- = Architectural Overview & Rationale +-- +-- Dhall is a programmable, strongly normalizing configuration language designed to +-- prevent unexpected failures at execution time. In Gachi, Dhall serves as the canonical +-- medium for defining project templates and configuration manifests because of its unique +-- structural characteristics: +-- +-- 1. __Totality and Termination Guarantees:__ +-- Dhall expressions are mathematically guaranteed to terminate. Unlike general-purpose +-- languages or Turing-complete template engines (e.g., Nix, Python scripts), a Dhall +-- template can never enter an infinite loop or deadlock the scaffolding engine. +-- +-- 2. __Hermetic and Side-Effect Free:__ +-- During evaluation, Dhall does not have access to ambient environment variables, arbitrary +-- filesystems, network sockets, or external process execution (unless explicit imports +-- are resolved by the host). This ensures that template instantiation is fully hermetic, +-- deterministic, and reproducible across disparate developer environments. +-- +-- 3. __Strong Static Typing:__ +-- Dhall configurations are statically typechecked against the expected schema before +-- any directory creation or file writing begins. Mismatched field names, missing attributes, +-- or incorrect types produce actionable, human-readable compiler diagnostics rather than +-- silent corruptions or half-initialized repositories. +-- +-- == Evaluation & Codec Integration +-- +-- This module leverages "Polytropos.Dhall" to bridge Dhall AST expressions ('Dhall.Core.Expr') +-- directly into high-performance Haskell structures: +-- +-- * Nominal decoding ('decodeProjectText') utilizes 'Polytropos.Dhall.GenericDhall' to +-- populate 'Project' structures in a single pass. +-- * Open row decoding ('decodeProjectRecText') extracts raw fields directly into Polytropos +-- flat 'Polytropos.Core.RowRep' memory structures with zero intermediate binary tree allocations. +-- +-- = When to Use This Module +-- +-- * Reading and evaluating @project.dhall@ files from disk or memory. +-- * Formatting 'Project' or 'ProjectRec' records back into canonical Dhall expressions. +-- * Obtaining the canonical Dhall schema definition ('projectSchemaDhall') for tooling or LSP integration. +-- +-- = Worked Example +-- +-- >>> import Gachi.Schema.Dhall +-- >>> proj <- decodeProjectText exampleProjectDhall +-- >>> projectName proj +-- "gongju" +module Gachi.Schema.Dhall + ( -- * High-Level Dhall Evaluation + decodeProjectText + , decodeProjectFile + , decodeProjectEither + , decodeProjectRecText + , decodeProjectRecEither + + -- * Rendering & Encoding + , renderProjectDhall + , renderProjectRecDhall + + -- * Embedded Dhall Schemas & Turnkey Templates + , projectSchemaDhall + , exampleProjectDhall + ) where + +import Control.Exception (SomeException, try) +import Data.Bifunctor (first) +import Data.Text (Text) +import qualified Dhall +import qualified Dhall.Core as Core +import Gachi.Schema.Project (Project, ProjectRec) + +-- | Decode a 'Project' specification from a raw Dhall text expression. +-- +-- Evaluates the Dhall abstract syntax tree, verifies all expected schema fields +-- against the nominal 'Project' definition, and constructs the resulting record. +-- +-- Throws a 'Dhall.Core.DhallErrors' exception if the expression fails to parse, +-- typecheck, or match the expected schema. +-- +-- Time complexity: Strictly linear in the size of the Dhall input expression. +decodeProjectText :: Text -> IO Project +decodeProjectText = Dhall.input Dhall.auto + +-- | Decode a 'Project' specification from a Dhall file located on disk. +-- +-- Automatically resolves relative local file imports (e.g., @./Schema.dhall@) +-- relative to the target file's parent directory. +-- +-- Throws an 'IOException' if the file does not exist, or a 'Dhall.Core.DhallErrors' +-- exception if evaluation fails. +decodeProjectFile :: FilePath -> IO Project +decodeProjectFile = Dhall.inputFile Dhall.auto + +-- | Safely decode a 'Project' from Dhall text without throwing runtime exceptions. +-- +-- Catches any 'SomeException' raised during parsing, typechecking, or normalization +-- and wraps it in a 'Left' containing the formatted diagnostic error message. +-- +-- Useful for CLI validation flags, interactive wizards, and language server linting passes. +decodeProjectEither :: Text -> IO (Either String Project) +decodeProjectEither txt = first show <$> (try (decodeProjectText txt) :: IO (Either SomeException Project)) + +-- | Decode an open heterogeneous 'ProjectRec' row record from a Dhall text expression. +-- +-- Directly unrolls Dhall record literals into Polytropos flat 'Data.Primitive.SmallArray' +-- memory slots in row order via 'Polytropos.Dhall', achieving zero intermediate binary tree +-- constructor allocations. +-- +-- Throws a 'Dhall.Core.DhallErrors' exception if the input expression violates the schema. +decodeProjectRecText :: Text -> IO ProjectRec +decodeProjectRecText = Dhall.input Dhall.auto + +-- | Safely decode an open heterogeneous 'ProjectRec' from Dhall text without throwing exceptions. +-- +-- Wraps any caught evaluation failure in 'Left' with the descriptive error message, +-- or returns 'Right' with the parsed 'ProjectRec'. +decodeProjectRecEither :: Text -> IO (Either String ProjectRec) +decodeProjectRecEither txt = first show <$> (try (decodeProjectRecText txt) :: IO (Either SomeException ProjectRec)) + +-- | Render a nominal 'Project' into canonical, pretty-printed Dhall source text. +-- +-- Emits a formatted Dhall record literal matching 'projectSchemaDhall'. +-- +-- Time complexity: Linear in the size of the project record structure. +renderProjectDhall :: Project -> Text +renderProjectDhall = Core.pretty . Dhall.embed Dhall.inject + +-- | Render an open heterogeneous 'ProjectRec' into canonical, pretty-printed Dhall source text. +-- +-- Directly inspects the contiguous 'Polytropos.Core.RowRep' memory buffer and emits +-- the corresponding Dhall record literal without building intermediate nominal ASTs. +renderProjectRecDhall :: ProjectRec -> Text +renderProjectRecDhall = Core.pretty . Dhall.embed Dhall.inject + +-- | The canonical Dhall schema defining 'Author', 'Package', 'Remote', and 'Project' types. +projectSchemaDhall :: Text +projectSchemaDhall = + "let Author : Type =\n\ + \ { name : Text\n\ + \ , email : Text\n\ + \ }\n\ + \\n\ + \let Package : Type =\n\ + \ { name : Text\n\ + \ , synopsis : Text\n\ + \ , exposes : List Text\n\ + \ }\n\ + \\n\ + \let Remote : Type =\n\ + \ { name : Text\n\ + \ , url : Text\n\ + \ }\n\ + \\n\ + \let Project : Type =\n\ + \ { name : Text\n\ + \ , description : Text\n\ + \ , license : Text\n\ + \ , author : Author\n\ + \ , ghcVersion : Text\n\ + \ , cabalVersion : Text\n\ + \ , packages : List Package\n\ + \ , remotes : List Remote\n\ + \ }\n\ + \\n\ + \in { Author = Author\n\ + \ , Package = Package\n\ + \ , Remote = Remote\n\ + \ , Project = Project\n\ + \ }\n" + +-- | Turnkey sample Dhall specification for the 'gongju' crucible project. +exampleProjectDhall :: Text +exampleProjectDhall = + "let Schema =\n\ + \ { Author = { name : Text, email : Text }\n\ + \ , Package = { name : Text, synopsis : Text, exposes : List Text }\n\ + \ , Remote = { name : Text, url : Text }\n\ + \ , Project =\n\ + \ { name : Text\n\ + \ , description : Text\n\ + \ , license : Text\n\ + \ , author : { name : Text, email : Text }\n\ + \ , ghcVersion : Text\n\ + \ , cabalVersion : Text\n\ + \ , packages : List { name : Text, synopsis : Text, exposes : List Text }\n\ + \ , remotes : List { name : Text, url : Text }\n\ + \ }\n\ + \ }\n\ + \\n\ + \let project : Schema.Project =\n\ + \ { name = \"gongju\"\n\ + \ , description = \"Type-level utility functions and Peano arithmetic crucible\"\n\ + \ , license = \"EUPL-1.2\"\n\ + \ , author =\n\ + \ { name = \"Nadia Yvette Chambers\"\n\ + \ , email = \"nadia.yvette.chambers@ik.me\"\n\ + \ }\n\ + \ , ghcVersion = \"9.14.1\"\n\ + \ , cabalVersion = \"3.18\"\n\ + \ , packages =\n\ + \ [ { name = \"gongju\"\n\ + \ , synopsis = \"Pure Peano type-level utilities and HList operations\"\n\ + \ , exposes =\n\ + \ [ \"Gongju.Peano\"\n\ + \ , \"Gongju.Composition\"\n\ + \ , \"Gongju.Positional\"\n\ + \ , \"Gongju.Permute\"\n\ + \ , \"Gongju.HList\"\n\ + \ ]\n\ + \ }\n\ + \ ]\n\ + \ , remotes =\n\ + \ [ { name = \"github\"\n\ + \ , url = \"git@github.com:NadiaYvette/gongju.git\"\n\ + \ }\n\ + \ , { name = \"gitlab\"\n\ + \ , url = \"git@gitlab.com:NadiaYvette/gongju.git\"\n\ + \ }\n\ + \ ]\n\ + \ }\n\ + \\n\ + \in project\n" diff --git a/src/Gachi/Schema/Project.hs b/src/Gachi/Schema/Project.hs new file mode 100644 --- /dev/null +++ b/src/Gachi/Schema/Project.hs @@ -0,0 +1,464 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Module: Gachi.Schema.Project +-- Description: Strongly-typed nominal records and open row representations for projects +-- +-- Defines foundational schema types for declarative workspace and package configurations: +-- 'Author', 'PackageSpec', 'RemoteSpec', and 'Project'. +-- +-- All types provide both nominal representations deriving 'FromDhall' / 'ToDhall' via +-- 'GenericDhall' and isomorphic open row representations ('ProjectRec', 'AuthorRec', etc.) +-- backed by Polytropos flat 'Record' storage. +-- +-- = Architectural Overview & Rationale +-- +-- In Gachi's infrastructure model, all repository scaffolding, configuration synthesis, +-- and project retrofitting operate on declarative, hermetic schemas encoded in the +-- Dhall configuration language. Rather than relying on fragile untyped string substitution +-- (such as Jinja, Mustache, or sed expressions), Gachi models repository metadata as +-- strongly-typed algebraic records. +-- +-- == Duality: Nominal Records and Open Rows +-- +-- This module implements a deliberate structural duality: +-- +-- 1. __Nominal Representations ('Project', 'Author', etc.):__ +-- Provide standard Haskell data types with 'Generic' deriving. These types interface +-- seamlessly with Dhall via 'Polytropos.Dhall.GenericDhall' through @DerivingVia@, +-- enabling automatic decoder ('FromDhall') and encoder ('ToDhall') synthesis. +-- +-- 2. __Open Row Isomorphisms ('ProjectRec', 'AuthorRec', etc.):__ +-- Provide isomorphic open record types backed by Polytropos contiguous +-- 'Polytropos.Core.RowRep' storage. In the open row representation, field values reside in +-- contiguous 'Data.Primitive.SmallArray' slots, permitting dynamic field extension, +-- narrowing, and sub-row projection without intermediate data type declarations. +-- +-- == Ecosystem Invariants & Licensing +-- +-- All project skeletons generated or verified by Gachi adhere to core ecosystem policies: +-- +-- * __Licensing Discipline:__ By default, all ecosystem assets are licensed under +-- the European Union Public Licence (EUPL-1.2) or Apache-2.0. The EUPL is legally +-- interoperable across 22 European languages and compatible with GPLv2/v3 while protecting +-- upstream authors against SaaS-loophole proprietary enclosure. +-- * __Toolchain Pinning:__ Projects explicitly pin GHC 9.14.1 and Cabal 3.18, enabling +-- reproducible, bit-identical build artifacts across heterogeneous development workstations +-- and automated CI matrices. +-- * __Modular Multi-Package DAGs:__ Large systems are decomposed into fine-grained packages +-- (e.g., @*-core@, @*-schema@, @*-cli@) with explicit module exposure lists, maximizing +-- compilation parallelism and enforcing clean architectural boundaries. +-- +-- = When to Use This Module +-- +-- * Reading, validating, or writing Dhall project manifests (@project.dhall@). +-- * Generating multi-package workspace structures in @gachi init@. +-- * Converting between nominal Haskell configurations and open row representations. +-- +-- = Worked Example +-- +-- >>> import Gachi.Schema.Project +-- >>> let auth = Author { name = "Nadia Yvette Chambers", email = "nadia.yvette.chambers@ik.me" } +-- >>> let proj = defaultProject "gongju" auth +-- >>> projectName proj +-- "gongju" +-- >>> projectLicense proj +-- "EUPL-1.2" +module Gachi.Schema.Project + ( -- * Nominal Schema Data Types + Author(..) + , PackageSpec(..) + , RemoteSpec(..) + , Project(..) + + -- * Field Projection Aliases + , authorName + , authorEmail + , packageName + , packageSynopsis + , packageExposes + , remoteName + , remoteUrl + , projectName + , projectDescription + , projectLicense + , projectAuthor + , projectGhcVersion + , projectCabalVersion + , projectPackages + , projectRemotes + + -- * Open Row Types + , AuthorRow + , AuthorRec + , toAuthorRec + , fromAuthorRec + + , PackageRow + , PackageRec + , toPackageRec + , fromPackageRec + + , RemoteRow + , RemoteRec + , toRemoteRec + , fromRemoteRec + + , ProjectRow + , ProjectRec + , toProjectRec + , fromProjectRec + + -- * Defaults & Canonical Invariants + , defaultProject + , defaultPackage + , canonicalLicense + , canonicalGhcVersion + , canonicalCabalVersion + ) where + +import Data.Text (Text) +import Data.Functor.Identity (Identity(..)) +import Dhall (FromDhall, ToDhall) +import GHC.Generics (Generic) +import Polytropos + ( Pair(..) + , Record + ) +import Polytropos.Core + ( RowRep(..) + , fieldAt + , noInlineUnsafeCo + , productRep + ) +import Polytropos.Dhall (GenericDhall(..)) + +-- | Author and maintainer metadata for a project. +data Author = Author + { name :: !Text + -- ^ Full personal or organizational author name. + , email :: !Text + -- ^ Contact email address. + } deriving stock (Generic, Show, Eq) + deriving (FromDhall, ToDhall) via (GenericDhall Author) + +-- | Specification for an individual Cabal package within a multi-package workspace. +data PackageSpec = PackageSpec + { name :: !Text + -- ^ Package name (e.g., @"gachi-core"@). + , synopsis :: !Text + -- ^ Short one-line synopsis of package purpose. + , exposes :: ![Text] + -- ^ List of exposed top-level modules. + } deriving stock (Generic, Show, Eq) + deriving (FromDhall, ToDhall) via (GenericDhall PackageSpec) + +-- | Remote Git repository configuration for multi-forge mirroring. +data RemoteSpec = RemoteSpec + { name :: !Text + -- ^ Remote identifier (e.g., @"github"@, @"gitlab"@, @"radicle"@). + , url :: !Text + -- ^ Canonical fetch/push URL. + } deriving stock (Generic, Show, Eq) + deriving (FromDhall, ToDhall) via (GenericDhall RemoteSpec) + +-- | Comprehensive declarative specification for a project workspace. +-- +-- See Note [Dhall Parameterized Skeleton Templating] [ref:note-dhall-skeleton-templating]. +data Project = Project + { name :: !Text + -- ^ Canonical project name. + , description :: !Text + -- ^ Human-readable project description and mission. + , license :: !Text + -- ^ SPDX license identifier (defaults to @"EUPL-1.2"@). + , author :: !Author + -- ^ Primary maintainer or author identity. + , ghcVersion :: !Text + -- ^ Pinned GHC compiler release (e.g., @"9.14.1"@). + , cabalVersion :: !Text + -- ^ Pinned Cabal specification release (e.g., @"3.18"@). + , packages :: ![PackageSpec] + -- ^ Modular package hierarchy constituting this workspace. + , remotes :: ![RemoteSpec] + -- ^ Multi-forge remotes configured for replication. + } deriving stock (Generic, Show, Eq) + deriving (FromDhall, ToDhall) via (GenericDhall Project) + +-------------------------------------------------------------------------------- +-- Field Projection Aliases (disambiguating DuplicateRecordFields when needed) +-------------------------------------------------------------------------------- + +-- | Disambiguated projection selector for 'Author' name. +-- +-- Time complexity: @O(1)@ direct pattern match. +authorName :: Author -> Text +authorName (Author n _) = n + +-- | Disambiguated projection selector for 'Author' email. +-- +-- Time complexity: @O(1)@ direct pattern match. +authorEmail :: Author -> Text +authorEmail (Author _ e) = e + +-- | Disambiguated projection selector for 'PackageSpec' name. +-- +-- Time complexity: @O(1)@ direct pattern match. +packageName :: PackageSpec -> Text +packageName (PackageSpec n _ _) = n + +-- | Disambiguated projection selector for 'PackageSpec' synopsis. +-- +-- Time complexity: @O(1)@ direct pattern match. +packageSynopsis :: PackageSpec -> Text +packageSynopsis (PackageSpec _ s _) = s + +-- | Disambiguated projection selector for 'PackageSpec' exposed modules. +-- +-- Time complexity: @O(1)@ direct pattern match. +packageExposes :: PackageSpec -> [Text] +packageExposes (PackageSpec _ _ ex) = ex + +-- | Disambiguated projection selector for 'RemoteSpec' name. +-- +-- Time complexity: @O(1)@ direct pattern match. +remoteName :: RemoteSpec -> Text +remoteName (RemoteSpec n _) = n + +-- | Disambiguated projection selector for 'RemoteSpec' URL. +-- +-- Time complexity: @O(1)@ direct pattern match. +remoteUrl :: RemoteSpec -> Text +remoteUrl (RemoteSpec _ u) = u + +-- | Disambiguated projection selector for 'Project' name. +-- +-- Time complexity: @O(1)@ direct pattern match. +projectName :: Project -> Text +projectName (Project n _ _ _ _ _ _ _) = n + +-- | Disambiguated projection selector for 'Project' description. +-- +-- Time complexity: @O(1)@ direct pattern match. +projectDescription :: Project -> Text +projectDescription (Project _ d _ _ _ _ _ _) = d + +-- | Disambiguated projection selector for 'Project' license. +-- +-- Time complexity: @O(1)@ direct pattern match. +projectLicense :: Project -> Text +projectLicense (Project _ _ l _ _ _ _ _) = l + +-- | Disambiguated projection selector for 'Project' author. +-- +-- Time complexity: @O(1)@ direct pattern match. +projectAuthor :: Project -> Author +projectAuthor (Project _ _ _ a _ _ _ _) = a + +-- | Disambiguated projection selector for 'Project' GHC version. +-- +-- Time complexity: @O(1)@ direct pattern match. +projectGhcVersion :: Project -> Text +projectGhcVersion (Project _ _ _ _ g _ _ _) = g + +-- | Disambiguated projection selector for 'Project' Cabal version. +-- +-- Time complexity: @O(1)@ direct pattern match. +projectCabalVersion :: Project -> Text +projectCabalVersion (Project _ _ _ _ _ c _ _) = c + +-- | Disambiguated projection selector for 'Project' packages. +-- +-- Time complexity: @O(1)@ direct pattern match. +projectPackages :: Project -> [PackageSpec] +projectPackages (Project _ _ _ _ _ _ pkgs _) = pkgs + +-- | Disambiguated projection selector for 'Project' remotes. +-- +-- Time complexity: @O(1)@ direct pattern match. +projectRemotes :: Project -> [RemoteSpec] +projectRemotes (Project _ _ _ _ _ _ _ rms) = rms + +-------------------------------------------------------------------------------- +-- Open Row Representations (Polytropos Flat Memory Records) +-------------------------------------------------------------------------------- + +-- | Heterogeneous type-level row for 'Author'. +type AuthorRow = '["name" ':= Text, "email" ':= Text] + +-- | Open record type for 'Author'. +type AuthorRec = Record AuthorRow + +-- | Convert nominal 'Author' into open 'AuthorRec'. +-- +-- Packs fields into a contiguous 2-element 'Data.Primitive.SmallArray' in row order: +-- Slot 0 (@"name"@) and Slot 1 (@"email"@). +-- +-- Time complexity: @O(1)@. +toAuthorRec :: Author -> AuthorRec +toAuthorRec (Author n e) = + RowRep (productRep [Identity (noInlineUnsafeCo n), Identity (noInlineUnsafeCo e)]) + +-- | Convert open 'AuthorRec' into nominal 'Author'. +-- +-- Dereferences contiguous array slots via 'fieldAt' with zero intermediate heap allocation. +-- +-- Time complexity: @O(1)@. +fromAuthorRec :: AuthorRec -> Author +fromAuthorRec (RowRep rep) = Author + { name = let Identity n = fieldAt 0 rep in n + , email = let Identity e = fieldAt 1 rep in e + } + +-- | Heterogeneous type-level row for 'PackageSpec'. +type PackageRow = '["name" ':= Text, "synopsis" ':= Text, "exposes" ':= [Text]] + +-- | Open record type for 'PackageSpec'. +type PackageRec = Record PackageRow + +-- | Convert nominal 'PackageSpec' into open 'PackageRec'. +-- +-- Packs fields into a contiguous 3-element 'Data.Primitive.SmallArray' in row order: +-- Slot 0 (@"name"@), Slot 1 (@"synopsis"@), and Slot 2 (@"exposes"@). +-- +-- Time complexity: @O(1)@. +toPackageRec :: PackageSpec -> PackageRec +toPackageRec (PackageSpec n s ex) = + RowRep (productRep [Identity (noInlineUnsafeCo n), Identity (noInlineUnsafeCo s), Identity (noInlineUnsafeCo ex)]) + +-- | Convert open 'PackageRec' into nominal 'PackageSpec'. +-- +-- Dereferences contiguous array slots via 'fieldAt' with zero intermediate heap allocation. +-- +-- Time complexity: @O(1)@. +fromPackageRec :: PackageRec -> PackageSpec +fromPackageRec (RowRep rep) = PackageSpec + { name = let Identity n = fieldAt 0 rep in n + , synopsis = let Identity s = fieldAt 1 rep in s + , exposes = let Identity ex = fieldAt 2 rep in ex + } + +-- | Heterogeneous type-level row for 'RemoteSpec'. +type RemoteRow = '["name" ':= Text, "url" ':= Text] + +-- | Open record type for 'RemoteSpec'. +type RemoteRec = Record RemoteRow + +-- | Convert nominal 'RemoteSpec' into open 'RemoteRec'. +-- +-- Packs fields into a contiguous 2-element 'Data.Primitive.SmallArray' in row order: +-- Slot 0 (@"name"@) and Slot 1 (@"url"@). +-- +-- Time complexity: @O(1)@. +toRemoteRec :: RemoteSpec -> RemoteRec +toRemoteRec (RemoteSpec n u) = + RowRep (productRep [Identity (noInlineUnsafeCo n), Identity (noInlineUnsafeCo u)]) + +-- | Convert open 'RemoteRec' into nominal 'RemoteSpec'. +-- +-- Dereferences contiguous array slots via 'fieldAt' with zero intermediate heap allocation. +-- +-- Time complexity: @O(1)@. +fromRemoteRec :: RemoteRec -> RemoteSpec +fromRemoteRec (RowRep rep) = RemoteSpec + { name = let Identity n = fieldAt 0 rep in n + , url = let Identity u = fieldAt 1 rep in u + } + +-- | Heterogeneous type-level row for 'Project'. +type ProjectRow = + '[ "name" ':= Text + , "description" ':= Text + , "license" ':= Text + , "author" ':= Author + , "ghcVersion" ':= Text + , "cabalVersion" ':= Text + , "packages" ':= [PackageSpec] + , "remotes" ':= [RemoteSpec] + ] + +-- | Open record type for 'Project'. +type ProjectRec = Record ProjectRow + +-- | Convert nominal 'Project' into open 'ProjectRec'. +-- +-- Packs all 8 project fields into a single contiguous 'Data.Primitive.SmallArray' in row order: +-- Slot 0 (@"name"@), Slot 1 (@"description"@), Slot 2 (@"license"@), Slot 3 (@"author"@), +-- Slot 4 (@"ghcVersion"@), Slot 5 (@"cabalVersion"@), Slot 6 (@"packages"@), and Slot 7 (@"remotes"@). +-- +-- Time complexity: @O(1)@. +toProjectRec :: Project -> ProjectRec +toProjectRec (Project n d l a g c pkgs rms) = + RowRep (productRep + [ Identity (noInlineUnsafeCo n) + , Identity (noInlineUnsafeCo d) + , Identity (noInlineUnsafeCo l) + , Identity (noInlineUnsafeCo a) + , Identity (noInlineUnsafeCo g) + , Identity (noInlineUnsafeCo c) + , Identity (noInlineUnsafeCo pkgs) + , Identity (noInlineUnsafeCo rms) + ]) + +-- | Convert open 'ProjectRec' into nominal 'Project'. +-- +-- Unpacks the flat contiguous array into the nominal 'Project' record in $O(1)$ time +-- with zero intermediate tree allocations. +-- +-- Time complexity: @O(1)@. +fromProjectRec :: ProjectRec -> Project +fromProjectRec (RowRep rep) = Project + { name = let Identity n = fieldAt 0 rep in n + , description = let Identity d = fieldAt 1 rep in d + , license = let Identity l = fieldAt 2 rep in l + , author = let Identity a = fieldAt 3 rep in a + , ghcVersion = let Identity g = fieldAt 4 rep in g + , cabalVersion = let Identity c = fieldAt 5 rep in c + , packages = let Identity pkgs = fieldAt 6 rep in pkgs + , remotes = let Identity rms = fieldAt 7 rep in rms + } + +-------------------------------------------------------------------------------- +-- Canonical Ecosystem Standards & Turnkey Defaults +-------------------------------------------------------------------------------- + +-- | Canonical default license per ecosystem policy: EUPL-1.2. +canonicalLicense :: Text +canonicalLicense = "EUPL-1.2" + +-- | Canonical default GHC version: 9.14.1. +canonicalGhcVersion :: Text +canonicalGhcVersion = "9.14.1" + +-- | Canonical default Cabal specification version: 3.18. +canonicalCabalVersion :: Text +canonicalCabalVersion = "3.18" + +-- | Construct a default 'PackageSpec' with canonical conventions. +defaultPackage :: Text -> PackageSpec +defaultPackage pkgName = PackageSpec + { name = pkgName + , synopsis = "Foundational package for " <> pkgName + , exposes = [] + } + +-- | Construct a turnkey 'Project' with canonical defaults. +-- +-- Automatically configures EUPL-1.2 license, GHC 9.14.1, Cabal 3.18, and a primary package. +defaultProject :: Text -> Author -> Project +defaultProject projName auth = Project + { name = projName + , description = "Ecosystem workspace for " <> projName + , license = canonicalLicense + , author = auth + , ghcVersion = canonicalGhcVersion + , cabalVersion = canonicalCabalVersion + , packages = [defaultPackage projName] + , remotes = [] + } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Test.Hspec +import Control.Exception (SomeException, try) +import Data.Either (isLeft) +import Data.Text (Text) + +import Gachi.Schema + +main :: IO () +main = hspec do + -- Tested against Note [Dhall Parameterized Skeleton Templating] [ref:note-dhall-skeleton-templating] + describe "Gachi.Schema Nominal Types & Invariants" do + it "constructs turnkey default projects with canonical ecosystem standards" do + let auth = Author { name = "Nadia Yvette Chambers", email = "nadia.yvette.chambers@ik.me" } + proj = defaultProject "gongju" auth + + projectName proj `shouldBe` "gongju" + projectLicense proj `shouldBe` "EUPL-1.2" + projectGhcVersion proj `shouldBe` "9.14.1" + projectCabalVersion proj `shouldBe` "3.18" + authorName (projectAuthor proj) `shouldBe` "Nadia Yvette Chambers" + authorEmail (projectAuthor proj) `shouldBe` "nadia.yvette.chambers@ik.me" + length (projectPackages proj) `shouldBe` 1 + case projectPackages proj of + (pkg : _) -> packageName pkg `shouldBe` "gongju" + [] -> expectationFailure "expected at least one package" + projectRemotes proj `shouldBe` [] + + it "exposes projection helpers disambiguating DuplicateRecordFields" do + let auth = Author { name = "Ada Lovelace", email = "ada@analytical.org" } + pkg = PackageSpec { name = "engine-core", synopsis = "Babbage engine simulator", exposes = ["Engine.Core"] } + remote = RemoteSpec { name = "origin", url = "git@github.com:Ada/engine.git" } + proj = Project + { name = "analytical-engine" + , description = "Computational pioneer project" + , license = canonicalLicense + , author = auth + , ghcVersion = canonicalGhcVersion + , cabalVersion = canonicalCabalVersion + , packages = [pkg] + , remotes = [remote] + } + + projectName proj `shouldBe` "analytical-engine" + authorName auth `shouldBe` "Ada Lovelace" + packageName pkg `shouldBe` "engine-core" + packageSynopsis pkg `shouldBe` "Babbage engine simulator" + packageExposes pkg `shouldBe` ["Engine.Core"] + remoteName remote `shouldBe` "origin" + remoteUrl remote `shouldBe` "git@github.com:Ada/engine.git" + + describe "Gachi.Schema Open Row Isomorphisms" do + it "faithfully roundtrips Author <-> AuthorRec" do + let auth = Author { name = "Charles Babbage", email = "charles@difference.org" } + recA = toAuthorRec auth + auth' = fromAuthorRec recA + auth' `shouldBe` auth + + it "faithfully roundtrips PackageSpec <-> PackageRec" do + let pkg = PackageSpec + { name = "difference-math" + , synopsis = "Polynomial difference computation" + , exposes = ["Math.Difference", "Math.Gear"] + } + recP = toPackageRec pkg + pkg' = fromPackageRec recP + pkg' `shouldBe` pkg + + it "faithfully roundtrips RemoteSpec <-> RemoteRec" do + let rm = RemoteSpec { name = "radicle", url = "rad:git:hnrk12345678" } + recR = toRemoteRec rm + rm' = fromRemoteRec recR + rm' `shouldBe` rm + + it "faithfully roundtrips Project <-> ProjectRec" do + let auth = Author { name = "Nadia Yvette Chambers", email = "nadia.yvette.chambers@ik.me" } + proj = defaultProject "gachi" auth + recProj = toProjectRec proj + proj' = fromProjectRec recProj + proj' `shouldBe` proj + + -- Tested against Note [Dhall Parameterized Skeleton Templating] [ref:note-dhall-skeleton-templating] + describe "Gachi.Schema.Dhall Codecs & Evaluation" do + it "decodes embedded exampleProjectDhall into strongly typed Project" do + proj <- decodeProjectText exampleProjectDhall + projectName proj `shouldBe` "gongju" + projectLicense proj `shouldBe` "EUPL-1.2" + authorName (projectAuthor proj) `shouldBe` "Nadia Yvette Chambers" + length (projectPackages proj) `shouldBe` 1 + case projectPackages proj of + (pkg : _) -> do + packageName pkg `shouldBe` "gongju" + packageExposes pkg `shouldBe` + [ "Gongju.Peano" + , "Gongju.Composition" + , "Gongju.Positional" + , "Gongju.Permute" + , "Gongju.HList" + ] + [] -> expectationFailure "expected package list to be non-empty" + length (projectRemotes proj) `shouldBe` 2 + map remoteName (projectRemotes proj) `shouldBe` ["github", "gitlab"] + + it "decodes open heterogeneous ProjectRec directly from Dhall" do + recProj <- decodeProjectRecText exampleProjectDhall + let proj = fromProjectRec recProj + projectName proj `shouldBe` "gongju" + projectLicense proj `shouldBe` "EUPL-1.2" + + it "roundtrips nominal Project through renderProjectDhall and decodeProjectText" do + let auth = Author { name = "Nadia Yvette Chambers", email = "nadia.yvette.chambers@ik.me" } + orig = defaultProject "polytropos" auth + rendered = renderProjectDhall orig + decoded <- decodeProjectText rendered + decoded `shouldBe` orig + + it "roundtrips open ProjectRec through renderProjectRecDhall and decodeProjectRecText" do + let auth = Author { name = "Nadia Yvette Chambers", email = "nadia.yvette.chambers@ik.me" } + origRec = toProjectRec (defaultProject "polytropos" auth) + rendered = renderProjectRecDhall origRec + decodedRec <- decodeProjectRecText rendered + fromProjectRec decodedRec `shouldBe` fromProjectRec origRec + projectName (fromProjectRec decodedRec) `shouldBe` "polytropos" + + it "gracefully returns Left for malformed Dhall expressions" do + let invalidDhall = "{ name = \"broken\", license = 123 }" :: Text + res <- decodeProjectEither invalidDhall + res `shouldSatisfy` isLeft + + it "decodes project specification from disk file" do + res1 <- try (decodeProjectFile "dhall/example-project.dhall") :: IO (Either SomeException Project) + proj <- case res1 of + Right p -> pure p + Left _ -> decodeProjectFile "packages/gachi-schema/dhall/example-project.dhall" + projectName proj `shouldBe` "gongju" + projectLicense proj `shouldBe` "EUPL-1.2"