diff --git a/src/virtual/make_config_lib.ml b/src/virtual/make_config_lib.ml index bd0af5a..0fb40c3 100644 --- a/src/virtual/make_config_lib.ml +++ b/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