typed schema for scfg

src/virtual/make_config_lib.ml

@@ -1,34 +1,166 @@
-module Schema = struct
-  type nil = N
+(* TODO
+   custom parameter type
+   print a scfg
+   handle failures *)
+module M = struct
+  open Scfg
 
-  type empty = E
+  type nil = NIL
 
-  (*type dir = D*)
+  type dir
 
-  type _ kind =
-    | Bool : bool kind
-    | Int : int kind
-    | Float : float kind
-    | String : string kind
+  type param
 
-  (* todo: one general gadt for params and schema? *)
-  type _ params =
-    | Nil : nil params
-    | Cons : ('a kind * 'b params) -> ('a * 'b) params
+  type ('a, 'b) directive =
+    { name : string
+    ; params : 'a
+    ; children : 'b
+    }
 
-  type _ schema =
-    | Empty : empty schema
-    | Dir : (string * 'a params * 'b schema) -> ('a * 'b) schema
+  type ('r, _) t =
+    | Bool : (param, bool) t
+    | Int : (param, int) t
+    | Float : (param, float) t
+    | String : (param, string) t
+    | Directive :
+        (string * (param, 'a) t_list * (dir, 'b) t_list)
+        -> (dir, ('a, 'b) directive) t
+    | Leaf : (string * (param, 'a) t_list) -> (dir, ('a, nil) directive) t
 
-  let v = Dir ("void", Nil, Empty)
+  and ('r, _) t_list =
+    | Nil : ('r, nil) t_list
+    | One : ('r, 'a) t -> ('r, 'a) t_list
+    | Cons : (('r, 'a) t * ('r, 'b) t_list) -> ('r, 'a * 'b) t_list
 
-  let v1 = Dir ("cc", Cons (String, Nil), v)
+  let error () = Fmt.failwith "invalid schema"
 
-  let v2 =
-    Dir
-      ( "salut"
-      , Cons (String, Cons (Bool, Cons (Float, Nil)))
-      , Dir ("euj", Cons (Int, Nil), v1) )
+  let conv_param : type a. (param, a) t -> string -> a =
+   fun param_t v ->
+    try
+      match param_t with
+      | Bool -> bool_of_string v
+      | Int -> int_of_string v
+      | Float -> float_of_string v
+      | String -> v
+    with Invalid_argument _ -> error ()
+
+  let rec conv_param_list : type a. (param, a) t_list -> string list -> a =
+   fun param_l_t l ->
+    match param_l_t with
+    | Nil -> ( match l with [] -> NIL | _ -> error () )
+    | One k -> ( match l with [ hd ] -> conv_param k hd | _ -> error () )
+    | Cons (k, k_l) -> (
+      match l with
+      | [] -> error ()
+      | hd :: tl -> (conv_param k hd, conv_param_list k_l tl) )
+
+  let rec conv_dir : type a. (dir, a) t -> Types.directive -> a =
+   fun dir_t dir ->
+    match dir_t with
+    | Directive (name, params, children) -> (
+      match String.equal name dir.name with
+      | false -> error ()
+      | true ->
+        { name
+        ; params = conv_param_list params dir.params
+        ; children = conv children dir.children
+        } )
+    | Leaf (name, params) -> (
+      match String.equal name dir.name with
+      | false -> error ()
+      | true ->
+        { name; params = conv_param_list params dir.params; children = NIL } )
+
+  and conv : type a. (dir, a) t_list -> Types.config -> a =
+   fun dir_l_t l ->
+    match dir_l_t with
+    | Nil -> ( match l with [] -> NIL | _ -> error () )
+    | One k -> ( match l with [ hd ] -> conv_dir k hd | _ -> error () )
+    | Cons (k, k_l) -> (
+      match l with [] -> error () | hd :: tl -> (conv_dir k hd, conv k_l tl) )
+
+  let ( @^ ) = fun a b -> Cons (a, b)
+
+  let ( @+ ) = fun a b -> Cons (a, One b)
+
+  let ( !@ ) = fun a -> One a
+
+  let directive : type a b.
+         string
+      -> (param, a) t_list
+      -> (dir, b) t_list
+      -> (dir, (a, b) directive) t =
+   fun name params children -> Directive (name, params, children)
+
+  let leaf : type a. string -> (param, a) t_list -> (dir, (a, nil) directive) t
+      =
+   fun name params -> Leaf (name, params)
+end
+
+module M_test = struct
+  open M
+
+  module Uuu = struct
+    module Pp = struct
+      let hide_data : (param, 'a) t * ('a ) -> (param, 'a) t =
+        fun (t, _v) ->
+
+      let ( @^ ) = fun a b -> Cons (hide_data a, b)
+
+      let ( @+ ) = fun a b -> Cons (hide_data a, One (hide_data b))
+
+      let ( !@ ) = fun a -> One (hide_data a)
+    end
+
+    open Pp
+
+    let sch = !@(leaf "cc" (!@ (String, "uu" )   ) )
+  end
+
+  let schema_1 = !@(leaf "cc" !@String)
+
+  let schema_2 =
+    !@(directive "salut" (String @^ Bool @+ Float) !@(leaf "euj" !@Int))
+
+  let schema_3 = leaf "cc" !@String @^ leaf "cc" !@String @+ leaf "cc" !@String
+
+  let txt_1 = Scfg.Parse.from_string {|cc param_1
+      |} |> Result.get_ok
+
+  let txt_2 =
+    Scfg.Parse.from_string
+      {|salut param_str true 0.46 {
+    euj 3456
+    }
+      |}
+    |> Result.get_ok
+
+  let txt_3 =
+    Scfg.Parse.from_string {|cc sava
+  cc sava
+  cc sava
+      |}
+    |> Result.get_ok
+
+  let () =
+    let v_1 = conv schema_1 txt_1 in
+    let { name; params; children } = v_1 in
+    assert (name = "cc");
+    assert (params = "param_1");
+    assert (children = NIL);
+
+    let v_2 = conv schema_2 txt_2 in
+    let { name; params; children } = v_2 in
+    assert (name = "salut");
+    assert (params = ("param_str", (true, 0.46)));
+    assert (children.name = "euj");
+    assert (children.params = 3456);
+
+    let v_3 = conv schema_3 txt_3 in
+    let dir1, (dir2, dir3) = v_3 in
+    assert (dir1 = dir2);
+    assert (dir2 = dir3);
+    ()
 end
 
 (* ------ *)