add schema

src/dune

@@ -1,6 +1,6 @@
 (library
  (public_name scfg)
- (modules lexer menhir_parser parse pp query types)
+ (modules lexer menhir_parser parse pp query schema types)
  (private_modules lexer menhir_parser)
  (preprocess
   (pps sedlex.ppx))

src/schema.ml

@@ -0,0 +1,145 @@
+type nil = Nil
+
+type param
+
+type dir
+
+type ('a, 'b) directive =
+  { name : string
+  ; params : 'a
+  ; children : 'b
+  }
+
+module Field_type = struct
+  type _ t =
+    | String : string t
+    | Bool : bool t
+    | Int : int t
+    | Float : float t
+end
+
+type (_, _) t =
+  | Field : 'a Field_type.t -> ('a, param) t
+  | Directive :
+      string * ('a, param) t * ('b, dir) t
+      -> (('a, 'b) directive, dir) t
+  | Product : ('i * ('a, 'i, 'k) product) -> ('a, 'k) t
+
+and (_, _, _) product =
+  | Proj_end : ('a, 'a, 'k) product
+  | Proj : (('b, 'k) t * ('a, 'i, 'k) product) -> ('a, 'b -> 'i, 'k) product
+
+type _ kt =
+  | P : string list -> param kt
+  | D : Types.directive list -> dir kt
+
+exception Schema_exn of string
+
+let error msg = raise (Schema_exn (Fmt.str "invalid schema: %s" msg))
+
+let rec length : type a k. (a, k) t -> int =
+ fun ty ->
+  match ty with
+  | Field _ -> 1
+  | Directive _ -> 1
+  | Product (_i, prod) -> length_prod prod
+
+and length_prod : type a b k. (a, b, k) product -> int =
+ fun p ->
+  match p with Proj_end -> 0 | Proj (tk, prod) -> length tk + length_prod prod
+
+let conv_field : type a. a Field_type.t -> string -> a =
+ fun ty v ->
+  match ty with
+  | String -> v
+  | Bool -> (
+    match bool_of_string_opt v with
+    | None -> error (Fmt.str "%s does not match a bool" v)
+    | Some b -> b )
+  | Int -> (
+    match int_of_string_opt v with
+    | None -> error (Fmt.str "%s does not match a int" v)
+    | Some b -> b )
+  | Float -> (
+    match float_of_string_opt v with
+    | None -> error (Fmt.str "%s does not match a float" v)
+    | Some b -> b )
+
+let singleton l = match l with [ v ] -> v | _ -> error "expected singleton"
+
+let rec conv : type a k. (a, k) t -> k kt -> a =
+ fun ty k ->
+  match (ty, k) with
+  | Field ty, P l -> conv_field ty (singleton l)
+  | Directive (name, p_ty, c_ty), D l -> (
+    let v = singleton l in
+    match String.equal v.name name with
+    | false -> error (Fmt.str "name mismatch: `%s` <> `%s`" name v.name)
+    | true ->
+      let params = conv p_ty (P v.params) in
+      let children = conv c_ty (D v.children) in
+      { name; params; children } )
+  | Product ty, k -> conv_prod ty k
+
+and conv_prod : type a i k. i * (a, i, k) product -> k kt -> a =
+ fun (intro, ty) k ->
+  match (ty, k) with
+  | Proj_end, P l -> (
+    match l with [] -> intro | _ -> error "too many items" )
+  | Proj_end, D l -> (
+    match l with [] -> intro | _ -> error "too many items" )
+  | Proj (ty, prod), P l ->
+    let i = length ty in
+    let l1 = List.take i l in
+    let l2 = List.drop i l in
+    let b = conv ty (P l1) in
+    let a = conv_prod (intro b, prod) (P l2) in
+    a
+  | Proj (ty, prod), D l ->
+    let i = length ty in
+    let l1 = List.take i l in
+    let l2 = List.drop i l in
+    let b = conv ty (D l1) in
+    let a = conv_prod (intro b, prod) (D l2) in
+    a
+
+let string = Field Field_type.String
+
+let bool = Field Field_type.Bool
+
+let int = Field Field_type.Int
+
+let float = Field Field_type.Float
+
+let directive name params children = Directive (name, params, children)
+
+let nil = Product (Nil, Proj_end)
+
+let product intro prod = Product (intro, prod)
+
+let proj t prod = Proj (t, prod)
+
+let proj_end = Proj_end
+
+let t1 t1 =
+  let intro = fun x1 -> x1 in
+  product intro @@ proj t1 proj_end
+
+let t2 t1 t2 =
+  let intro = fun x1 x2 -> (x1, x2) in
+  product intro @@ proj t1 @@ proj t2 proj_end
+
+let t3 t1 t2 t3 =
+  let intro = fun x1 x2 x3 -> (x1, x2, x3) in
+  product intro @@ proj t1 @@ proj t2 @@ proj t3 proj_end
+
+let t4 t1 t2 t3 t4 =
+  let intro = fun x1 x2 x3 x4 -> (x1, x2, x3, x4) in
+  product intro @@ proj t1 @@ proj t2 @@ proj t3 @@ proj t4 proj_end
+
+let t5 t1 t2 t3 t4 t5 =
+  let intro = fun x1 x2 x3 x4 x5 -> (x1, x2, x3, x4, x5) in
+  product intro @@ proj t1 @@ proj t2 @@ proj t3 @@ proj t4 @@ proj t5 proj_end
+
+let conv schema (config : Types.config) =
+  try Ok (conv schema (D config)) with Schema_exn s -> Error (`Msg s)

src/schema.mli

@@ -0,0 +1,71 @@
+(* inspired by caqti:
+   https://github.com/paurkedal/ocaml-caqti/blob/master/caqti/lib-template/row_type.mli *)
+
+(** Module providing types and functions to define a config schema. *)
+
+type nil = Nil
+
+type param
+
+type dir
+
+type ('a, 'b) directive =
+  { name : string
+  ; params : 'a
+  ; children : 'b
+  }
+
+module Field_type : sig
+  type _ t =
+    | String : string t
+    | Bool : bool t
+    | Int : int t
+    | Float : float t
+end
+
+type (_, _) t =
+  | Field : 'a Field_type.t -> ('a, param) t
+  | Directive :
+      string * ('a, param) t * ('b, dir) t
+      -> (('a, 'b) directive, dir) t
+  | Product : ('i * ('a, 'i, 'k) product) -> ('a, 'k) t
+
+and (_, _, _) product =
+  | Proj_end : ('a, 'a, 'k) product
+  | Proj : (('b, 'k) t * ('a, 'i, 'k) product) -> ('a, 'b -> 'i, 'k) product
+
+val string : (string, param) t
+
+val bool : (bool, param) t
+
+val int : (int, param) t
+
+val float : (float, param) t
+
+val directive :
+  string -> ('a, param) t -> ('b, dir) t -> (('a, 'b) directive, dir) t
+
+val nil : (nil, 'k) t
+
+val t1 : ('a, 'k) t -> ('a, 'k) t
+
+val t2 : ('a, 'k) t -> ('b, 'k) t -> ('a * 'b, 'k) t
+
+val t3 : ('a, 'k) t -> ('b, 'k) t -> ('c, 'k) t -> ('a * 'b * 'c, 'k) t
+
+val t4 :
+     ('a, 'k) t
+  -> ('b, 'k) t
+  -> ('c, 'k) t
+  -> ('d, 'k) t
+  -> ('a * 'b * 'c * 'd, 'k) t
+
+val t5 :
+     ('a, 'k) t
+  -> ('b, 'k) t
+  -> ('c, 'k) t
+  -> ('d, 'k) t
+  -> ('e, 'k) t
+  -> ('a * 'b * 'c * 'd * 'e, 'k) t
+
+val conv : ('a, dir) t -> Types.config -> ('a, [ `Msg of string ]) result

test/unit/main.ml

@@ -63,4 +63,38 @@ let () =
   | Error (`Msg "directive n1.2: want param at index 5, got only 2") -> ()
   | 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) )
+
+let txt =
+  Parse.from_string
+    {|dir true str1 "str2" {
+  dir_1 false {
+    dir_1_1
+  }
+  dir_2 str3
+  }|}
+  |> 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 () = Format.printf "all tests OK! 🐱"