Merge pull request #109 from xhtmlboi/inherit-models

Add `Yocaml.Data.Validation.sub_record`

Author: xhtmlboi

CHANGES.md

@@ -3,6 +3,7 @@
 #### Yocaml 
 
 - Add `Action.remove_residuals` for erasing residuals files (by [xvw](https://xvw.lol))
+- Add `Yocaml.Data.Validation.sub_record` for validating a complete structure as a record field (by [xvw](https://xvw.lol))
 
 #### Yocaml_git
 

doc/data_validation.mld

@@ -407,6 +407,39 @@ Build a validator for lists of users! Excellent! It is partly for this reason
 that errors are so complex; they must be nestable and handle increasingly
 complex cases to ensure the reusability of validators.
 
+{3 Sub-records}
+
+Sometimes, you may want to validate a record as a minimum record with
+additional data. For example, consider this type:
+
+{eof@ocaml[
+type p = {
+  page: Yocaml.Archetype.Page.t
+; authors: string list
+; category: string
+}
+]eof}
+
+In this example, we would like our source to be “a page” with two
+additional fields.
+
+{!val:Yocaml.Data.Validation.sub_record} allows you to validate an
+entire structure as a record field. For example:
+
+{eof@ocaml[
+let validate_p =
+  let open Yocaml.Data.Validation in
+  record (fun fields ->
+    let+ page = sub_record fields Yocaml.Archetype.Page.validate
+    and+ authors = optional_or ~default:[] fields "authors" (list_of string)
+    and+ category = required fields "category" string in
+    { page; authors; category }
+  )
+]eof}
+
+The overall idea is to enable the validation of a known model to be
+applied within the validation of a record.
+
 {2 Additional Validators}
 
 There are other additional validators that fit with common OCaml types. For

lib/core/data.ml

@@ -41,6 +41,7 @@ let list_of f l = list @@ List.map f l
 let record fields = Record fields
 let option some = Option.fold ~none:null ~some
 let path p = string (Path.to_string p)
+let mk_record = record
 
 let sum f value =
   let k, v = f value in
@@ -141,6 +142,7 @@ module Validation = struct
   and record_error =
     | Missing_field of { field : string }
     | Invalid_field of { given : t; field : string; error : value_error }
+    | Invalid_subrecord of value_error
 
   type 'a validated_value = ('a, value_error) result
   type 'a validated_record = ('a, record_error Nel.t) result
@@ -367,6 +369,10 @@ module Validation = struct
     let opt = optional assoc field validator in
     Result.bind opt (function Some x -> Ok x | None -> Ok default)
 
+  let sub_record assoc validator =
+    validator (mk_record assoc)
+    |> Result.map_error (fun err -> Nel.singleton (Invalid_subrecord err))
+
   module Infix = struct
     let ( & ) l r x = Result.bind (l x) r
     let ( / ) l r x = Result.fold ~ok:Result.ok ~error:(fun _ -> r x) (l x)
@@ -411,10 +417,6 @@ module Validation = struct
 
   let path = string $ Path.from_string
 
-  (** {2 String validators}
-
-      Validators specifically for string values. *)
-
   module String = struct
     let string_pp = Format.pp_print_string
     let string_equal = Stdlib.String.equal
@@ -425,7 +427,6 @@ module Validation = struct
     let not_equal not_expected actual =
       not_equal ~pp:string_pp ~equal:string_equal not_expected actual
 
-    (* Length-based validators - using Int.equal and Int.compare as suggested *)
     let has_length expected_length actual =
       let actual_length = Stdlib.String.length actual in
       if Int.equal actual_length expected_length then Ok actual
@@ -580,8 +581,6 @@ module Validation = struct
     let where = with_pp where
   end
 
-  (** {2 Validator combinators} *)
-
   let negate validator x =
     match validator x with
     | Ok _ -> fail_with ~given:"<value>" "should not satisfy the validator"

lib/core/data.mli

@@ -136,6 +136,7 @@ module Validation : sig
   and record_error =
     | Missing_field of { field : string }
     | Invalid_field of { given : t; field : string; error : value_error }
+    | Invalid_subrecord of value_error
 
   type 'a validated_value = ('a, value_error) result
   (** Used to validate data described by type {!type:t} to build validation
@@ -188,6 +189,10 @@ module Validation : sig
   (** [record v x] ensure that [x] has the shape validated by [v] (all errors
       are collected). *)
 
+  val sub_record :
+    (string * t) list -> (t -> 'a validated_value) -> 'a validated_record
+  (** [sub_record] allows you to validate a record during record validation. *)
+
   val option : (t -> 'a validated_value) -> t -> 'a option validated_value
   (** [option v x] validate a value using [v] that can be [null] wrapped into an
       option. *)

lib/core/diagnostic.ml

@@ -65,6 +65,10 @@ and pp_record_error custom_error ppf = function
         field
         (pp_validation_error custom_error)
         error Data.pp given
+  | Data.Validation.Invalid_subrecord error ->
+      Format.fprintf ppf "Invalid subrecord @[<2>%a@]"
+        (pp_validation_error custom_error)
+        error
 
 let pp_provider_error custom_error ppf = function
   | Required.Parsing_error { given; message } ->

test/archetype/page_test.ml

@@ -0,0 +1,121 @@
+(* YOCaml a static blog generator.
+   Copyright (C) 2025 The Funkyworkers and The YOCaml's developers
+
+   This program is free software: you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation, either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program.  If not, see <https://www.gnu.org/licenses/>. *)
+
+type t = {
+    page : Yocaml.Archetype.Page.t
+  ; category : string option
+  ; authors : string list
+}
+
+let normalize_t { page; category; authors } =
+  let open Yocaml.Data in
+  record
+    (Yocaml.Archetype.Page.normalize page
+    @ [
+        ("category", option string category)
+      ; ("authors", (list_of string) authors)
+      ])
+
+let testable_t =
+  let pp ppf x = Format.fprintf ppf "%a" Yocaml.Data.pp (normalize_t x)
+  and equal a b = Yocaml.Data.equal (normalize_t a) (normalize_t b) in
+  Alcotest.testable pp equal
+
+let validate_t =
+  let open Yocaml.Data.Validation in
+  record (fun fields ->
+      let+ page = sub_record fields Yocaml.Archetype.Page.validate
+      and+ category = optional fields "category" string
+      and+ authors =
+        optional_or ~default:[] fields "authors" (list_of string)
+      in
+      { page; category; authors })
+
+let test_validate_with_subpage_1 =
+  let open Alcotest in
+  test_case "Validate using a page inside a different value - 1" `Quick
+    (fun () ->
+      let input =
+        let open Yocaml.Data in
+        record []
+      and input_page =
+        let open Yocaml.Data in
+        record []
+      and category = None
+      and authors = [] in
+      let expected =
+        Result.map
+          (fun page -> { page; category; authors })
+          (Yocaml.Archetype.Page.validate input_page)
+      and computed = validate_t input in
+      check
+        Test_lib.Testable.(validated_value testable_t)
+        "shoudl be equal" expected computed)
+
+let test_validate_with_subpage_2 =
+  let open Alcotest in
+  test_case "Validate using a page inside a different value - 2" `Quick
+    (fun () ->
+      let input =
+        let open Yocaml.Data in
+        record [ ("page_title", string "foo") ]
+      and input_page =
+        let open Yocaml.Data in
+        record [ ("page_title", string "foo") ]
+      and category = None
+      and authors = [] in
+      let expected =
+        Result.map
+          (fun page -> { page; category; authors })
+          (Yocaml.Archetype.Page.validate input_page)
+      and computed = validate_t input in
+      check
+        Test_lib.Testable.(validated_value testable_t)
+        "shoudl be equal" expected computed)
+
+let test_validate_with_subpage_3 =
+  let open Alcotest in
+  test_case "Validate using a page inside a different value - 3" `Quick
+    (fun () ->
+      let input =
+        let open Yocaml.Data in
+        record
+          [
+            ("page_title", string "foo")
+          ; ("category", string "article")
+          ; ("authors", list_of string [ "xvw"; "xhtmlboi"; "msp"; "grm" ])
+          ]
+      and input_page =
+        let open Yocaml.Data in
+        record [ ("page_title", string "foo") ]
+      and category = Some "article"
+      and authors = [ "xvw"; "xhtmlboi"; "msp"; "grm" ] in
+      let expected =
+        Result.map
+          (fun page -> { page; category; authors })
+          (Yocaml.Archetype.Page.validate input_page)
+      and computed = validate_t input in
+      check
+        Test_lib.Testable.(validated_value testable_t)
+        "shoudl be equal" expected computed)
+
+let cases =
+  ( "Yocaml.Archetype.Path"
+  , [
+      test_validate_with_subpage_1
+    ; test_validate_with_subpage_2
+    ; test_validate_with_subpage_3
+    ] )

test/archetype/page_test.mli

@@ -0,0 +1,18 @@
+(* YOCaml a static blog generator.
+   Copyright (C) 2025 The Funkyworkers and The YOCaml's developers
+
+   This program is free software: you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation, either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program.  If not, see <https://www.gnu.org/licenses/>. *)
+
+val cases : string * unit Alcotest.test_case list
+(** Returns the list of test cases. *)

test/archetype/yocaml_archetype_test.ml

@@ -14,4 +14,5 @@
    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <https://www.gnu.org/licenses/>. *)
 
-let () = Alcotest.run "Yocaml Archetype test" [ Datetime_test.cases ]
+let () =
+  Alcotest.run "Yocaml Archetype test" [ Datetime_test.cases; Page_test.cases ]

test/lib/testable.ml

@@ -148,6 +148,14 @@ and pp_record_error cst ppf err =
            ; field "given" (fun (_, _, g) -> g) (parens Yocaml.Data.pp)
            ])
         ppf (f, error, given)
+  | Invalid_subrecord error ->
+      braces
+        (record
+           [
+             field "kind" (Fun.const "invalid subrecord") string
+           ; field "error" Fun.id (parens (pp_value_error cst))
+           ])
+        ppf error
 
 let rec equal_value_error cst a b =
   let open Yocaml.Data.Validation in