rm scfg wip

src/virtual/make_config_lib.ml

@@ -1,170 +1,3 @@
-(* TODO
-   custom parameter type
-   print a scfg
-   handle failures *)
-module M = struct
-  open Scfg
-
-  type nil = NIL
-
-  type dir
-
-  type param
-
-  type ('a, 'b) directive =
-    { name : string
-    ; params : 'a
-    ; children : 'b
-    }
-
-  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
-
-  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 error () = Fmt.failwith "invalid schema"
-
-  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
-
-(* ------ *)
-
 type _ tag =
   | String : string tag
   | Bool : bool tag