add Schema.custom

src/schema.ml

@@ -121,6 +121,11 @@ let proj t prod = Proj (t, prod)
 
 let proj_end = Proj_end
 
+let custom : type a b k. (a -> (b, string) result) -> (a, k) t -> (b, k) t =
+ fun decode t ->
+  let intro s = match decode s with Ok x -> x | Error msg -> error msg in
+  product intro @@ proj t @@ proj_end
+
 let t1 t1 =
   let intro = fun x1 -> x1 in
   product intro @@ proj t1 proj_end

src/schema.mli

@@ -45,6 +45,8 @@ val float : (float, param) t
 val directive :
   string -> ('a, param) t -> ('b, dir) t -> (('a, 'b) directive, dir) t
 
+val custom : ('a -> ('b, string) result) -> ('a, 'k) t -> ('b, 'k) t
+
 val nil : (nil, 'k) t
 
 val t1 : ('a, 'k) t -> ('a, 'k) t

test/unit/main.ml

@@ -64,37 +64,54 @@ let () =
   | Error _ | Ok _ -> assert false
 
 (** Testing schema. *)
-let schema =
-  let open Schema in
-  directive "dir" (t3 bool string string)
-    (t2
-       (directive "dir_1" bool (directive "dir_1_1" nil nil))
-       (directive "dir_2" string nil) )
+module Test_schema = struct
+  open Schema
 
-let txt =
-  Parse.from_string
-    {|dir true str1 "str2" {
-  dir_1 false {
+  let rev_string : (string, param) t -> (string, param) t =
+    let decode =
+     fun s ->
+      let len = String.length s in
+      let s_rev = String.init len (fun i -> String.get s (len - i - 1)) in
+      Ok s_rev
+    in
+    custom decode
+
+  let len_string : (string, param) t -> (int, param) t =
+    let decode = fun s -> String.length s |> Result.ok in
+    custom decode
+
+  let schema =
+    directive "dir" (t3 bool string string)
+      (t2
+         (directive "dir_1"
+            (t2 bool (rev_string string))
+            (directive "dir_1_1" nil nil) )
+         (directive "dir_2" (t2 string (len_string string)) nil) )
+
+  let txt =
+    Parse.from_string
+      {|dir true str1 "str2" {
+  dir_1 false naquadah {
     dir_1_1
   }
-  dir_2 str3
+  dir_2 str3 four
   }|}
-  |> Result.get_ok
+    |> Result.get_ok
 
-let () =
-  let open Schema in
-  let v = conv schema txt |> Result.get_ok in
-  assert (
-    v
-    = { name = "dir"
-      ; params = (true, "str1", "str2")
-      ; children =
-          ( { name = "dir_1"
-            ; params = false
-            ; children = { name = "dir_1_1"; params = Nil; children = Nil }
-            }
-          , { name = "dir_2"; params = "str3"; children = Nil } )
-      } );
-  ()
+  let () =
+    let v = conv schema txt |> Result.get_ok in
+    assert (
+      v
+      = { name = "dir"
+        ; params = (true, "str1", "str2")
+        ; children =
+            ( { name = "dir_1"
+              ; params = (false, "hadauqan")
+              ; children = { name = "dir_1_1"; params = Nil; children = Nil }
+              }
+            , { name = "dir_2"; params = ("str3", 4); children = Nil } )
+        } );
+    ()
+end
 
 let () = Format.printf "all tests OK! 🐱"