From 0ba222850396361e7a339811cd85abf33ea3e165 Mon Sep 17 00:00:00 2001 From: ·𐑑𐑴𐑕𐑑𐑩𐑀 Date: Thu, 11 Dec 2025 20:58:19 +0000 Subject: make KDL module + fix casing --- lib/error.ml | 2 +- lib/kDL.ml | 95 ++++++++++++ lib/kDL_lens_result.ml | 388 +++++++++++++++++++++++++++++++++++++++++++++++++ lib/kdl_lens_result.ml | 388 ------------------------------------------------- lib/manifest.ml | 134 ++++++++--------- lib/nixtamal.ml | 8 +- lib/util.ml | 91 ------------ test/test_input.ml | 22 +-- 8 files changed, 566 insertions(+), 562 deletions(-) create mode 100644 lib/kDL.ml create mode 100644 lib/kDL_lens_result.ml delete mode 100644 lib/kdl_lens_result.ml diff --git a/lib/error.ml b/lib/error.ml index 4255c79..a658f50 100644 --- a/lib/error.ml +++ b/lib/error.ml @@ -5,7 +5,7 @@ open Name type manifest_error = [ - | `Parsing of Util.KDL.Valid.err list + | `Parsing of KDL.Valid.err list | `Not_set_up | `File_already_exists ] diff --git a/lib/kDL.ml b/lib/kDL.ml new file mode 100644 index 0000000..550c26f --- /dev/null +++ b/lib/kDL.ml @@ -0,0 +1,95 @@ +(*─────────────────────────────────────────────────────────────────────────────┐ +β”‚ SPDX-FileCopyrightText: 2025 toastal β”‚ +β”‚ SPDX-License-Identifier: LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception β”‚ +└─────────────────────────────────────────────────────────────────────────────*) +(* extend & fix casing for ocaml-kdl *) +include Kdl + +let of_flow flow = + try + Eio.Buf_read.parse_exn + (fun buf -> Eio.Buf_read.take_all buf |> Kdl.of_string) + ~max_size: max_int + flow + with + | exn -> failwith (Printexc.to_string exn) + +let to_flow flow doc = + Eio.Buf_write.with_flow flow @@ fun buf -> + let out_string s off len = + String.sub s off len |> Eio.Buf_write.string buf + in + let flush () = () in + let ppf = Format.make_formatter out_string flush in + + (* replace spaces with tabs for indentation *) + let base_fmt = Format.pp_get_formatter_out_functions ppf () in + let tabbed_fmt = {base_fmt with + out_indent = (fun n -> base_fmt.out_string (String.make n '\t') 0 n) + } + in + Format.pp_set_formatter_out_functions ppf tabbed_fmt; + + (* enable utf-8 and pretty-print *) + Fmt.set_utf_8 ppf true; + pp ppf doc; + Format.pp_print_flush ppf () + +module L = KDL_lens_result + +module Valid = struct + type err = [ + | L.lerr + | `ParseError of Kdl.error + | `OneRequired of string list + | `OnlyOneOf of string list + | `InvalidLatestCmd of string + | `InvalidHashAlgorithm of string + ] + [@@deriving show] + type 'a t = ('a, err list) result + let pp ~(ok : 'a Fmt.t) : 'a t Fmt.t = + Fmt.result ~ok ~error: (Fmt.list pp_err) + let map = Result.map + let map1 (f : 'a -> 'b) (vx : ('a, err) result) : 'b t = + match vx with + | Ok x -> Ok (f x) + | Error e -> Error [e] + let map_error = Result.map_error + let pure x = Ok x + let and_map (vx : 'a t) (vf : ('a -> 'b) t) = + match vx, vf with + | Ok x, Ok f -> Ok (f x) + | Error e, Ok _ -> Error e + | Ok _, Error e -> Error e + | Error e1, Error e2 -> Error (e2 @ e1) + let product (vx : 'a t) (vy : 'b t) = + match vx, vy with + | Ok x, Ok y -> Ok (x, y) + | Error e, Ok _ -> Error e + | Ok _, Error e -> Error e + | Error e1, Error e2 -> Error (e2 @ e1) + let and_map1 (vx : ('a, err) result) (vf : ('a -> 'b) t) = + match vx, vf with + | Ok x, Ok f -> Ok (f x) + | Error e, Ok _ -> Error [e] + | Ok _, Error e -> Error e + | Error e1, Error e2 -> Error (e2 @ [e1]) + let bind = Result.bind + let lift_lens (r : ('a, L.lerr) result) : ('a, err list) result = + Result.map_error (fun e -> ([e] :> err list)) r + let ll = lift_lens + let (let+) vx f = map f vx + let (and+) = product + let (let*) = bind +end + +type 'a codec = { + to_kdl: 'a -> t; + of_kdl: t -> 'a Valid.t +} + +type 'a node_codec = { + to_node: 'a -> node; + of_node: node -> 'a Valid.t +} diff --git a/lib/kDL_lens_result.ml b/lib/kDL_lens_result.ml new file mode 100644 index 0000000..9ead98e --- /dev/null +++ b/lib/kDL_lens_result.ml @@ -0,0 +1,388 @@ +(*─────────────────────────────────────────────────────────────────────────────┐ +β”‚ SPDX-FileCopyrightText: eilveli β”‚ +β”‚ SPDX-FileContributor: toastal Fmt.pf fmt "Cannot each" + | `Cannot_replace -> Fmt.pf fmt "Cannot replace" + | `Missing_annot -> Fmt.pf fmt "Missing annotation" + | `Missing_prop prop -> Fmt.pf fmt "Missing property β€œ%s”" prop + | `Missing_index idx -> Fmt.pf fmt "Missing index β€œ%d”" idx + | `Missing_top -> Fmt.pf fmt "Missing top-level node" + | `Not_found (name, annot) -> + begin + match annot with + | None -> Fmt.pf fmt "Not found β€œ%s”" name + | Some a -> Fmt.pf fmt "Not found β€œ%s” with annotation (%s)" name a + end + | `Mismatched_type -> Fmt.pf fmt "Mismatched type" + | `Wrong_type_bool -> Fmt.pf fmt "Wrong type, expected a boolean" + | `Wrong_type_float -> Fmt.pf fmt "Wrong type, expected a float" + | `Wrong_type_Int -> Fmt.pf fmt "Wrong type, expected an int" + | `Wrong_type_Int32 -> Fmt.pf fmt "Wrong type, expected an int32" + | `Wrong_type_Int64 -> Fmt.pf fmt "Wrong type, expected an int64" + | `Wrong_type_native_int -> Fmt.pf fmt "Wrong type, expected a native int" + | `Wrong_type_null -> Fmt.pf fmt "Wrong type, expected a null" + | `Wrong_type_number -> Fmt.pf fmt "Wrong type, expected a number" + | `Wrong_type_string -> Fmt.pf fmt "Wrong type, expected a string" + | `Wrong_type_stringNumber -> Fmt.pf fmt "Wrong type, expected a string number" + +open Kdl + +(* note: we can possibly replace option with result for more detailed errors *) + +type ('s, 'a) lens = { + get: 's -> ('a, lerr) result; + set: 'a -> 's -> ('s, lerr) result; +} + +let get a lens = lens.get a + +let set a v lens = lens.set v a + +let get_exn a lens = + match lens.get a with + | Ok v -> v + (*| Error e -> failwith (String.concat "; " (List.map lerr_to_string e))*) + | Error e -> failwith (show_lerr e) + +let set_exn a v lens = + match lens.set v a with + | Ok v -> v + (*| Error e -> failwith (String.concat "; " (List.map lerr_to_string e))*) + | Error e -> failwith (show_lerr e) + +(* note: update can possibly be added to the definition of [lens] to increase + performance with more specialized implementations *) + +let update f a lens = + match lens.get a with + | Error e -> Error e + | Ok value -> + match f value with + | Ok value' -> lens.set value' a + | Error e -> Error e + +let compose l1 l2 = { + get = (fun x -> + match l2.get x with + | Ok x' -> l1.get x' + | Error e -> Error e + ); + set = (fun v a -> update (l1.set v) a l2) +} + +let ( // ) l1 l2 = compose l2 l1 + +let (|--) = ( // ) + +let (.@()) = get +let (.@() <-) a l v = set a v l + +let (.@!()) = get_exn +let (.@!() <-) a l v = set_exn a v l + +let node_name = { + get = (fun node -> Ok node.name); + set = (fun name node -> Ok {node with name}); +} + +let node_annot = { + get = (fun node -> Option.to_result ~none: `Missing_annot node.annot); + set = (fun annot node -> Ok {node with annot = Some annot}); +} + +(* Unset the annotation by passing None *) +let node_annot_opt = { + get = (fun node -> Ok node.annot); + set = (fun annot node -> Ok {node with annot}); +} + +let args = { + get = (fun node -> Ok node.args); + set = (fun args node -> Ok {node with args}); +} + +let props = { + get = (fun node -> Ok node.props); + set = (fun props node -> Ok {node with props}); +} + +let children = { + get = (fun node -> Ok node.children); + set = (fun children node -> Ok {node with children}); +} + +let top = { + get = (function node :: _ -> Ok node | [] -> Error `Missing_top); + set = (fun node -> function _ :: xs -> Ok (node :: xs) | [] -> Error `Missing_top); +} + +open struct + let nth_and_replace n x' list = + let found = ref false in + (* Note: Unlike List.mapi, this stops iterating when we've found the element *) + let [@tail_mod_cons] rec go i = function + | [] -> [] + | _ :: xs when i = n -> found := true; x' :: xs + | x :: xs -> x :: go (i + 1) xs + in + let result = go 0 list in + if !found then Ok result else Error (`Missing_index n) + + let filter_and_replace f replace_list list = + let found = ref false in + let f (replace, result) x = + if f x then + begin + found := true; + match replace with + | x' :: xs -> xs, x' :: result + | [] -> [], x :: result + end + else + replace, x :: result + in + let _, list = List.fold_left f (replace_list, []) list in + if !found then Ok (List.rev list) else Error `Cannot_replace + + let [@inline]matches_node ?annot name node = + String.equal node.name name + && ( + match annot with + | Some a -> + ( + match node.annot with + | Some a' -> String.equal a a' + | None -> false + ) + | None -> true + ) + + let rec find_node n annot name = function + | [] -> Error (`Not_found (name, annot)) + | x :: xs when matches_node ?annot name x -> + if n <= 0 then Ok x else find_node (n - 1) annot name xs + | _ :: xs -> find_node n annot name xs + + let find_and_replace_node nth annot name x' list = + let found = ref false in + let [@tail_mod_cons] rec go n = function + | [] -> [] + | x :: xs when matches_node ?annot name x -> + if n <= 0 then (found := true; x' :: xs) else x :: go (n - 1) xs + | x :: xs -> x :: go n xs + in + let result = go nth list in + if !found then Ok result else Error (`Not_found (name, annot)) +end + +let nth n = { + get = (fun list -> + List.nth_opt list n + |> Option.to_result ~none: (`Missing_index n) + ); + set = (fun x' list -> nth_and_replace n x' list) +} + +(* these operations are O(n), and update is quite inefficient *) +let arg n = { + (* Inlined [nth] instead of [args // nth n] *) + get = (fun node -> + List.nth_opt node.args n + |> Option.to_result ~none: (`Missing_index n) + ); + set = (fun arg' node -> + nth_and_replace n arg' node.args + |> Result.map (fun args -> {node with args}) + ) +} + +let first_arg = arg 0 + +let prop key = { + get = (fun node -> + List.assoc_opt key node.props + |> Option.to_result ~none: (`Missing_prop key) + ); + set = (fun v' node -> + let found = ref false in + let f (k, v) = if k = key then (found := true; k, v') else k, v in + let props = List.map f node.props in + if !found then Ok {node with props} else Error (`Missing_prop key) + ) +} + +let node ?(nth = 0) ?annot (name : string) = { + get = (fun nodes -> find_node nth annot name nodes); + set = (fun node' nodes -> find_and_replace_node nth annot name node' nodes) +} + +let node_many ?annot (name : string) = + let matches = matches_node ?annot name in + { + get = (fun nodes -> + match List.filter matches nodes with + | [] -> Error (`Not_found (name, annot)) + | xs -> Ok xs + ); + set = (fun nodes' nodes -> filter_and_replace matches nodes' nodes) + } + +let node_nth : int -> (node list, node) lens = nth + +(* TODO: get node by annot only? *) + +let child ?nth ?annot name = children // node ?nth ?annot name +let child_many ?annot name = children // node_many ?annot name +let child_nth n = children // node_nth n + +let value : (annot_value, value) lens = { + get = (fun (_, v) -> Ok v); + set = (fun v' (a, _) -> Ok (a, v')); +} + +let annot : (annot_value, string) lens = { + get = (fun (a, _) -> Option.to_result ~none: `Missing_annot a); + set = (fun a' (_, v) -> Ok (Some a', v)); +} + +let annot_opt : (annot_value, string option) lens = { + get = (fun (a, _) -> Ok a); + set = (fun a' (_, v) -> Ok (a', v)); +} + +let string = { + get = (function `String str -> Ok str | _ -> Error `Wrong_type_string); + set = (fun value' _value -> Ok (`String value')); +} + +(* Ast.Num.of_string not exposed *) +let number : (value, number) lens = { + get = (fun n -> L.number.get n |> Option.to_result ~none: `Wrong_type_number); + set = (fun num n -> L.number.set num n |> Option.to_result ~none: `Wrong_type_number); +} + +let string_number : (value, string) lens = { + get = (fun n -> L.string_number.get n |> Option.to_result ~none: `Wrong_type_stringNumber); + set = (fun x n -> L.string_number.set x n |> Option.to_result ~none: `Wrong_type_stringNumber); +} + +let float_number : (value, float) lens = { + get = (fun n -> L.float_number.get n |> Option.to_result ~none: `Wrong_type_float); + set = (fun x n -> L.float_number.set x n |> Option.to_result ~none: `Wrong_type_float); +} + +let int_number : (value, int) lens = { + get = (fun n -> L.int_number.get n |> Option.to_result ~none: `Wrong_type_Int); + set = (fun x n -> L.int_number.set x n |> Option.to_result ~none: `Wrong_type_Int); +} + +let int32_number : (value, int32) lens = { + get = (fun n -> L.int32_number.get n |> Option.to_result ~none: `Wrong_type_Int32); + set = (fun x n -> L.int32_number.set x n |> Option.to_result ~none: `Wrong_type_Int32); +} + +let int64_number : (value, int64) lens = { + get = (fun n -> L.int64_number.get n |> Option.to_result ~none: `Wrong_type_Int64); + set = (fun x n -> L.int64_number.set x n |> Option.to_result ~none: `Wrong_type_Int64); +} + +let nativeint_number : (value, nativeint) lens = { + get = (fun n -> L.nativeint_number.get n |> Option.to_result ~none: `Wrong_type_native_int); + set = (fun x n -> L.nativeint_number.set x n |> Option.to_result ~none: `Wrong_type_native_int); +} + +let bool = { + get = (function `Bool b -> Ok b | _ -> Error `Wrong_type_bool); + set = (fun value' _value -> Ok (`Bool value')) +} + +let null = { + get = (function `Null -> Ok () | _ -> Error `Wrong_type_null); + set = (fun _ _ -> Ok `Null) +} + +let string_value : (annot_value, string) lens = value // string +let number_value : (annot_value, number) lens = value // number +let string_number_value : (annot_value, string) lens = value // string_number +let float_number_value : (annot_value, float) lens = value // float_number +let int_number_value : (annot_value, int) lens = value // int_number +let int32_number_value : (annot_value, int32) lens = value // int32_number +let int64_number_value : (annot_value, int64) lens = value // int64_number +let nativeint_number_value : (annot_value, nativeint) lens = + value // nativeint_number +let bool_value : (annot_value, bool) lens = value // bool +let null_value : (annot_value, unit) lens = value // null + +let filter f = { + get = (fun list -> Ok (List.filter f list)); + set = (fun replace list -> filter_and_replace f replace list) +} + +open struct + exception Short_circuit + + let mapm_option f list = + let g a = + match f a with + | Ok x -> x + | Error _ -> raise_notrace Short_circuit + in + try + Ok (List.map g list) + with + | Short_circuit -> Error `Cannot_each +end + +let each l = { + get = (fun list -> mapm_option l.get list); + set = (fun replace_list list -> + let f (replace, result) v = + match replace with + | v' :: replace_rest -> + ( + match l.set v' v with + | Ok x -> replace_rest, x :: result + | Error _ -> raise_notrace Short_circuit + ) + | [] -> [], v :: result + in + try + let _, list = List.fold_left f (replace_list, []) list in + Ok (List.rev list) + with + | Short_circuit -> Error `Cannot_each + ) +} diff --git a/lib/kdl_lens_result.ml b/lib/kdl_lens_result.ml deleted file mode 100644 index 9ead98e..0000000 --- a/lib/kdl_lens_result.ml +++ /dev/null @@ -1,388 +0,0 @@ -(*─────────────────────────────────────────────────────────────────────────────┐ -β”‚ SPDX-FileCopyrightText: eilveli β”‚ -β”‚ SPDX-FileContributor: toastal Fmt.pf fmt "Cannot each" - | `Cannot_replace -> Fmt.pf fmt "Cannot replace" - | `Missing_annot -> Fmt.pf fmt "Missing annotation" - | `Missing_prop prop -> Fmt.pf fmt "Missing property β€œ%s”" prop - | `Missing_index idx -> Fmt.pf fmt "Missing index β€œ%d”" idx - | `Missing_top -> Fmt.pf fmt "Missing top-level node" - | `Not_found (name, annot) -> - begin - match annot with - | None -> Fmt.pf fmt "Not found β€œ%s”" name - | Some a -> Fmt.pf fmt "Not found β€œ%s” with annotation (%s)" name a - end - | `Mismatched_type -> Fmt.pf fmt "Mismatched type" - | `Wrong_type_bool -> Fmt.pf fmt "Wrong type, expected a boolean" - | `Wrong_type_float -> Fmt.pf fmt "Wrong type, expected a float" - | `Wrong_type_Int -> Fmt.pf fmt "Wrong type, expected an int" - | `Wrong_type_Int32 -> Fmt.pf fmt "Wrong type, expected an int32" - | `Wrong_type_Int64 -> Fmt.pf fmt "Wrong type, expected an int64" - | `Wrong_type_native_int -> Fmt.pf fmt "Wrong type, expected a native int" - | `Wrong_type_null -> Fmt.pf fmt "Wrong type, expected a null" - | `Wrong_type_number -> Fmt.pf fmt "Wrong type, expected a number" - | `Wrong_type_string -> Fmt.pf fmt "Wrong type, expected a string" - | `Wrong_type_stringNumber -> Fmt.pf fmt "Wrong type, expected a string number" - -open Kdl - -(* note: we can possibly replace option with result for more detailed errors *) - -type ('s, 'a) lens = { - get: 's -> ('a, lerr) result; - set: 'a -> 's -> ('s, lerr) result; -} - -let get a lens = lens.get a - -let set a v lens = lens.set v a - -let get_exn a lens = - match lens.get a with - | Ok v -> v - (*| Error e -> failwith (String.concat "; " (List.map lerr_to_string e))*) - | Error e -> failwith (show_lerr e) - -let set_exn a v lens = - match lens.set v a with - | Ok v -> v - (*| Error e -> failwith (String.concat "; " (List.map lerr_to_string e))*) - | Error e -> failwith (show_lerr e) - -(* note: update can possibly be added to the definition of [lens] to increase - performance with more specialized implementations *) - -let update f a lens = - match lens.get a with - | Error e -> Error e - | Ok value -> - match f value with - | Ok value' -> lens.set value' a - | Error e -> Error e - -let compose l1 l2 = { - get = (fun x -> - match l2.get x with - | Ok x' -> l1.get x' - | Error e -> Error e - ); - set = (fun v a -> update (l1.set v) a l2) -} - -let ( // ) l1 l2 = compose l2 l1 - -let (|--) = ( // ) - -let (.@()) = get -let (.@() <-) a l v = set a v l - -let (.@!()) = get_exn -let (.@!() <-) a l v = set_exn a v l - -let node_name = { - get = (fun node -> Ok node.name); - set = (fun name node -> Ok {node with name}); -} - -let node_annot = { - get = (fun node -> Option.to_result ~none: `Missing_annot node.annot); - set = (fun annot node -> Ok {node with annot = Some annot}); -} - -(* Unset the annotation by passing None *) -let node_annot_opt = { - get = (fun node -> Ok node.annot); - set = (fun annot node -> Ok {node with annot}); -} - -let args = { - get = (fun node -> Ok node.args); - set = (fun args node -> Ok {node with args}); -} - -let props = { - get = (fun node -> Ok node.props); - set = (fun props node -> Ok {node with props}); -} - -let children = { - get = (fun node -> Ok node.children); - set = (fun children node -> Ok {node with children}); -} - -let top = { - get = (function node :: _ -> Ok node | [] -> Error `Missing_top); - set = (fun node -> function _ :: xs -> Ok (node :: xs) | [] -> Error `Missing_top); -} - -open struct - let nth_and_replace n x' list = - let found = ref false in - (* Note: Unlike List.mapi, this stops iterating when we've found the element *) - let [@tail_mod_cons] rec go i = function - | [] -> [] - | _ :: xs when i = n -> found := true; x' :: xs - | x :: xs -> x :: go (i + 1) xs - in - let result = go 0 list in - if !found then Ok result else Error (`Missing_index n) - - let filter_and_replace f replace_list list = - let found = ref false in - let f (replace, result) x = - if f x then - begin - found := true; - match replace with - | x' :: xs -> xs, x' :: result - | [] -> [], x :: result - end - else - replace, x :: result - in - let _, list = List.fold_left f (replace_list, []) list in - if !found then Ok (List.rev list) else Error `Cannot_replace - - let [@inline]matches_node ?annot name node = - String.equal node.name name - && ( - match annot with - | Some a -> - ( - match node.annot with - | Some a' -> String.equal a a' - | None -> false - ) - | None -> true - ) - - let rec find_node n annot name = function - | [] -> Error (`Not_found (name, annot)) - | x :: xs when matches_node ?annot name x -> - if n <= 0 then Ok x else find_node (n - 1) annot name xs - | _ :: xs -> find_node n annot name xs - - let find_and_replace_node nth annot name x' list = - let found = ref false in - let [@tail_mod_cons] rec go n = function - | [] -> [] - | x :: xs when matches_node ?annot name x -> - if n <= 0 then (found := true; x' :: xs) else x :: go (n - 1) xs - | x :: xs -> x :: go n xs - in - let result = go nth list in - if !found then Ok result else Error (`Not_found (name, annot)) -end - -let nth n = { - get = (fun list -> - List.nth_opt list n - |> Option.to_result ~none: (`Missing_index n) - ); - set = (fun x' list -> nth_and_replace n x' list) -} - -(* these operations are O(n), and update is quite inefficient *) -let arg n = { - (* Inlined [nth] instead of [args // nth n] *) - get = (fun node -> - List.nth_opt node.args n - |> Option.to_result ~none: (`Missing_index n) - ); - set = (fun arg' node -> - nth_and_replace n arg' node.args - |> Result.map (fun args -> {node with args}) - ) -} - -let first_arg = arg 0 - -let prop key = { - get = (fun node -> - List.assoc_opt key node.props - |> Option.to_result ~none: (`Missing_prop key) - ); - set = (fun v' node -> - let found = ref false in - let f (k, v) = if k = key then (found := true; k, v') else k, v in - let props = List.map f node.props in - if !found then Ok {node with props} else Error (`Missing_prop key) - ) -} - -let node ?(nth = 0) ?annot (name : string) = { - get = (fun nodes -> find_node nth annot name nodes); - set = (fun node' nodes -> find_and_replace_node nth annot name node' nodes) -} - -let node_many ?annot (name : string) = - let matches = matches_node ?annot name in - { - get = (fun nodes -> - match List.filter matches nodes with - | [] -> Error (`Not_found (name, annot)) - | xs -> Ok xs - ); - set = (fun nodes' nodes -> filter_and_replace matches nodes' nodes) - } - -let node_nth : int -> (node list, node) lens = nth - -(* TODO: get node by annot only? *) - -let child ?nth ?annot name = children // node ?nth ?annot name -let child_many ?annot name = children // node_many ?annot name -let child_nth n = children // node_nth n - -let value : (annot_value, value) lens = { - get = (fun (_, v) -> Ok v); - set = (fun v' (a, _) -> Ok (a, v')); -} - -let annot : (annot_value, string) lens = { - get = (fun (a, _) -> Option.to_result ~none: `Missing_annot a); - set = (fun a' (_, v) -> Ok (Some a', v)); -} - -let annot_opt : (annot_value, string option) lens = { - get = (fun (a, _) -> Ok a); - set = (fun a' (_, v) -> Ok (a', v)); -} - -let string = { - get = (function `String str -> Ok str | _ -> Error `Wrong_type_string); - set = (fun value' _value -> Ok (`String value')); -} - -(* Ast.Num.of_string not exposed *) -let number : (value, number) lens = { - get = (fun n -> L.number.get n |> Option.to_result ~none: `Wrong_type_number); - set = (fun num n -> L.number.set num n |> Option.to_result ~none: `Wrong_type_number); -} - -let string_number : (value, string) lens = { - get = (fun n -> L.string_number.get n |> Option.to_result ~none: `Wrong_type_stringNumber); - set = (fun x n -> L.string_number.set x n |> Option.to_result ~none: `Wrong_type_stringNumber); -} - -let float_number : (value, float) lens = { - get = (fun n -> L.float_number.get n |> Option.to_result ~none: `Wrong_type_float); - set = (fun x n -> L.float_number.set x n |> Option.to_result ~none: `Wrong_type_float); -} - -let int_number : (value, int) lens = { - get = (fun n -> L.int_number.get n |> Option.to_result ~none: `Wrong_type_Int); - set = (fun x n -> L.int_number.set x n |> Option.to_result ~none: `Wrong_type_Int); -} - -let int32_number : (value, int32) lens = { - get = (fun n -> L.int32_number.get n |> Option.to_result ~none: `Wrong_type_Int32); - set = (fun x n -> L.int32_number.set x n |> Option.to_result ~none: `Wrong_type_Int32); -} - -let int64_number : (value, int64) lens = { - get = (fun n -> L.int64_number.get n |> Option.to_result ~none: `Wrong_type_Int64); - set = (fun x n -> L.int64_number.set x n |> Option.to_result ~none: `Wrong_type_Int64); -} - -let nativeint_number : (value, nativeint) lens = { - get = (fun n -> L.nativeint_number.get n |> Option.to_result ~none: `Wrong_type_native_int); - set = (fun x n -> L.nativeint_number.set x n |> Option.to_result ~none: `Wrong_type_native_int); -} - -let bool = { - get = (function `Bool b -> Ok b | _ -> Error `Wrong_type_bool); - set = (fun value' _value -> Ok (`Bool value')) -} - -let null = { - get = (function `Null -> Ok () | _ -> Error `Wrong_type_null); - set = (fun _ _ -> Ok `Null) -} - -let string_value : (annot_value, string) lens = value // string -let number_value : (annot_value, number) lens = value // number -let string_number_value : (annot_value, string) lens = value // string_number -let float_number_value : (annot_value, float) lens = value // float_number -let int_number_value : (annot_value, int) lens = value // int_number -let int32_number_value : (annot_value, int32) lens = value // int32_number -let int64_number_value : (annot_value, int64) lens = value // int64_number -let nativeint_number_value : (annot_value, nativeint) lens = - value // nativeint_number -let bool_value : (annot_value, bool) lens = value // bool -let null_value : (annot_value, unit) lens = value // null - -let filter f = { - get = (fun list -> Ok (List.filter f list)); - set = (fun replace list -> filter_and_replace f replace list) -} - -open struct - exception Short_circuit - - let mapm_option f list = - let g a = - match f a with - | Ok x -> x - | Error _ -> raise_notrace Short_circuit - in - try - Ok (List.map g list) - with - | Short_circuit -> Error `Cannot_each -end - -let each l = { - get = (fun list -> mapm_option l.get list); - set = (fun replace_list list -> - let f (replace, result) v = - match replace with - | v' :: replace_rest -> - ( - match l.set v' v with - | Ok x -> replace_rest, x :: result - | Error _ -> raise_notrace Short_circuit - ) - | [] -> [], v :: result - in - try - let _, list = List.fold_left f (replace_list, []) list in - Ok (List.rev list) - with - | Short_circuit -> Error `Cannot_each - ) -} diff --git a/lib/manifest.ml b/lib/manifest.ml index 9313dad..a669254 100644 --- a/lib/manifest.ml +++ b/lib/manifest.ml @@ -17,16 +17,16 @@ module Template = struct include Input.Template let to_arg ?annot tpl = - Kdl.arg ?annot (`String (take tpl)) + KDL.arg ?annot (`String (take tpl)) let of_child ~name kdl = - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in ll @@ Result.map make (kdl.@(child name // arg 0 // string_value)) let of_mirrors kdl = - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in ll @@ match kdl.@(child "mirrors" // args // each string_value) with | Ok ms -> Ok (List.map make ms) @@ -47,9 +47,9 @@ module File = struct let [@inline]of_manifest ({url; mirrors}: t) : Input.File.t = Input.File.make ~url ~mirrors () - let codec : t Util.KDL.codec = { + let codec : t KDL.codec = { to_kdl = (fun file -> - let open Kdl in + let open KDL in let nodes = if List.is_empty file.mirrors then [] @@ -62,8 +62,8 @@ module File = struct [node "file" nodes] ); of_kdl = (fun kdl -> - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in let* file = ll @@ kdl.@(node "file") in let+ url = Template.of_child ~name: "url" file and+ mirrors = Template.of_mirrors file @@ -86,9 +86,9 @@ module Archive = struct let [@inline]of_manifest ({url; mirrors}: t) : Input.Archive.t = Input.Archive.make ~url ~mirrors () - let codec : t Util.KDL.codec = { + let codec : t KDL.codec = { to_kdl = (fun archive -> - let open Kdl in + let open KDL in let url = node "url" ~args: [Template.to_arg archive.url] []; and nodes = @@ -101,8 +101,8 @@ module Archive = struct [node "archive" nodes] ); of_kdl = (fun kdl -> - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in let* archive = ll @@ kdl.@(node "archive") in let+ url = Template.of_child ~name: "url" archive and+ mirrors = Template.of_mirrors archive @@ -117,16 +117,16 @@ module Git = struct type t = Input.Git.Reference.t [@@deriving show, eq, qcheck] - let codec : t Util.KDL.codec = { + let codec : t KDL.codec = { to_kdl = (fun ref -> - let open Kdl in + let open KDL in match ref with - | `Branch b -> [Kdl.node "branch" ~args: [arg (`String b)] []] - | `Ref r -> [Kdl.node "ref" ~args: [arg (`String r)] []] + | `Branch b -> [KDL.node "branch" ~args: [arg (`String b)] []] + | `Ref r -> [KDL.node "ref" ~args: [arg (`String r)] []] ); of_kdl = (fun kdl -> - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in let node_names = ["branch"; "ref"] and branch = ll @@ kdl.@(node "branch" // arg 0 // string_value) and ref = ll @@ kdl.@(node "ref" // arg 0 // string_value) @@ -155,9 +155,9 @@ module Git = struct let [@inline]of_manifest ({repository; mirrors; reference; submodules; lfs}: t) : Input.Git.t = Input.Git.make ~repository ~mirrors ~reference ~submodules ~lfs () - let codec : t Util.KDL.codec = { + let codec : t KDL.codec = { to_kdl = (fun git -> - let open Kdl in + let open KDL in let repository = node "repository" ~args: [Template.to_arg git.repository] [] and nodes = @@ -181,8 +181,8 @@ module Git = struct [node "git" nodes] ); of_kdl = (fun kdl -> - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in let* git = ll @@ kdl.@(node "git") in let+ repository = Template.of_child ~name: "repository" git and+ mirrors = Template.of_mirrors git @@ -238,17 +238,17 @@ module Darcs = struct ] [@@deriving show, eq, qcheck] - let codec : t Util.KDL.codec = { + let codec : t KDL.codec = { to_kdl = (fun ref -> - let open Kdl in + let open KDL in match ref with - | `Context (`Stated sc) -> [Kdl.node "context" ~args: [arg (`String sc)] []] + | `Context (`Stated sc) -> [KDL.node "context" ~args: [arg (`String sc)] []] | `Context (`Assumed _) -> [] - | `Tag t -> [Kdl.node "tag" ~args: [arg (`String t)] []] + | `Tag t -> [KDL.node "tag" ~args: [arg (`String t)] []] ); of_kdl = (fun kdl -> - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in let node_names = ["tag"; "context"] and context = ll @@ kdl.@(node "context" // arg 0 // string_value) and tag = ll @@ kdl.@(node "tag" // arg 0 // string_value) @@ -275,9 +275,9 @@ module Darcs = struct let [@inline]of_manifest ({repository; mirrors; reference}: t) : Input.Darcs.t = Input.Darcs.make ~repository ~mirrors ~reference () - let codec : t Util.KDL.codec = { + let codec : t KDL.codec = { to_kdl = (fun darcs -> - let open Kdl in + let open KDL in let repository = node "repository" ~args: [Template.to_arg darcs.repository] [] and nodes = @@ -293,8 +293,8 @@ module Darcs = struct [node "darcs" nodes] ); of_kdl = (fun kdl -> - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in let* darcs = ll @@ kdl.@(node "darcs") in let+ repository = Template.of_child ~name: "repository" darcs and+ mirrors = Template.of_mirrors darcs @@ -310,17 +310,17 @@ module Pijul = struct type t = Input.Pijul.Reference.t [@@deriving show, eq, qcheck] - let codec : t Util.KDL.codec = { + let codec : t KDL.codec = { to_kdl = (fun ref -> - let open Kdl in + let open KDL in match ref with - | `Channel c -> [Kdl.node "channel" ~args: [arg (`String c)] []] - | `State s -> [Kdl.node "state" ~args: [arg (`String s)] []] - | `Change c -> [Kdl.node "change" ~args: [arg (`String c)] []] + | `Channel c -> [KDL.node "channel" ~args: [arg (`String c)] []] + | `State s -> [KDL.node "state" ~args: [arg (`String s)] []] + | `Change c -> [KDL.node "change" ~args: [arg (`String c)] []] ); of_kdl = (fun kdl -> - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in let node_names = ["channel"; "state"; "change"] and channel = ll @@ kdl.@(node "channel" // arg 0 // string_value) and state = ll @@ kdl.@(node "state" // arg 0 // string_value) @@ -349,9 +349,9 @@ module Pijul = struct let [@inline]of_manifest ({remote; mirrors; reference}: t) : Input.Pijul.t = Input.Pijul.make ~remote ~mirrors ~reference () - let codec : t Util.KDL.codec = { + let codec : t KDL.codec = { to_kdl = (fun pijul -> - let open Kdl in + let open KDL in let remote = node "remote" ~args: [Template.to_arg pijul.remote] [] and nodes = @@ -367,8 +367,8 @@ module Pijul = struct [node "pijul" nodes] ); of_kdl = (fun kdl -> - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in let* pijul = ll @@ kdl.@(node "pijul") in let+ remote = Template.of_child ~name: "remote" pijul and+ mirrors = Template.of_mirrors pijul @@ -403,7 +403,7 @@ module Kind = struct | `Darcs d -> `Darcs (Darcs.of_manifest d) | `Pijul p -> `Pijul (Pijul.of_manifest p) - let codec : t Util.KDL.codec = { + let codec : t KDL.codec = { to_kdl = (function | `File f -> File.codec.to_kdl f | `Archive a -> Archive.codec.to_kdl a @@ -449,9 +449,9 @@ module Hash = struct let [@inline]of_manifest ({algorithm; expected}: t) : Input.Hash.t = Input.Hash.make ~algorithm ?expected () - let codec : t Util.KDL.codec = { + let codec : t KDL.codec = { to_kdl = (fun hash -> - let open Kdl in + let open KDL in let props = match hash.expected with | None -> [] @@ -465,8 +465,8 @@ module Hash = struct [node "hash" ~props []] ); of_kdl = (fun kdl -> - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in let* hash = ll @@ kdl.@(node "hash") in let+ algorithm : Input.Hash.algorithm option = match hash.@(prop "algorithm") with @@ -518,11 +518,11 @@ module Latest_cmd = struct let [@inline]of_manifest (cmd : t) : Input.Latest.t = Input.Latest.make ?cmd () - let codec : t Util.KDL.codec = { + let codec : t KDL.codec = { to_kdl = (function | None -> [] | Some (exec, pipes) -> - let open Kdl in + let open KDL in let cmd_args ({prog; args}: Input.Latest.Cmd.cmd) = List.map (Template.to_arg) (prog :: args) in @@ -535,9 +535,9 @@ module Latest_cmd = struct [node "latest-cmd" nodes] ); of_kdl = (fun kdl -> - let open Util.KDL.L in - let open Util.KDL.Valid in - let extract_cmd (node : Kdl.node) : Input.Latest.Cmd.cmd Util.KDL.Valid.t = + let open KDL.L in + let open KDL.Valid in + let extract_cmd (node : KDL.node) : Input.Latest.Cmd.cmd KDL.Valid.t = if List.is_empty node.props then match Util.Non_empty_list.of_list node.args with | Some (arg_prog, arg_args) -> @@ -612,9 +612,9 @@ module Input' = struct frozen = mnfst.frozen; } - let codec : t Util.KDL.node_codec = { + let codec : t KDL.node_codec = { to_node = (fun input -> - let open Kdl in + let open KDL in let props = if input.frozen then [("frozen", arg (`Bool true))] @@ -628,8 +628,8 @@ module Input' = struct node (Name.take input.name) ~props nodes ); of_node = (fun input -> - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in let+ name = ll @@ input.@(node_name) |> Result.map Name.make @@ -663,9 +663,9 @@ type t = { } [@@deriving show, eq, make, qcheck] -let document_to_t (doc : Kdl.t) : t Util.KDL.Valid.t = - let open Util.KDL.L in - let open Util.KDL.Valid in +let document_to_t (doc : KDL.t) : t KDL.Valid.t = + let open KDL.L in + let open KDL.Valid in let* manifest_default_hash_algorithm : Input.Hash.algorithm option = match ll @@ doc.@(node "default_hash_algorithm" // arg 0 // string_value) with | Ok dha -> @@ -686,7 +686,7 @@ let document_to_t (doc : Kdl.t) : t Util.KDL.Valid.t = (* TODO: a lens would mean this could use `each` *) let rec get_inputs acc = function | [] -> acc - | (input : Kdl.node) :: inputs_tail -> + | (input : KDL.node) :: inputs_tail -> let acc' = match acc, Input'.codec.of_node input with | Error errs, Ok _ -> Error errs @@ -702,7 +702,7 @@ let document_to_t (doc : Kdl.t) : t Util.KDL.Valid.t = in make ~version ~inputs () -let manifest : Kdl.t option ref = ref None +let manifest : KDL.t option ref = ref None let exists () : bool = let working_dir = Working_directory.get () in @@ -716,14 +716,14 @@ let read () = Logs.info (fun m -> m "Reading manifest @@ %a …" Eio.Path.pp filepath); let* kdl = Eio.Path.with_open_in filepath @@ fun flow -> - Util.KDL.of_flow flow + KDL.of_flow flow in let () = manifest := Some kdl in Ok kdl let make ?(version = "0.1.0") () = Logs.app (fun m -> m "Making manifest file @@ version:%s" version); - let open Kdl in + let open KDL in let doc = [ node "version" ~args: [arg (`String version)] []; node "inputs" ( @@ -734,7 +734,7 @@ let make ?(version = "0.1.0") () = ); ] in - Logs.debug (fun m -> m "New KDL doc:@;%a@." Kdl.pp doc); + Logs.debug (fun m -> m "New KDL doc:@;%a@." KDL.pp doc); manifest := Some doc let write () : (unit, error) result = @@ -756,7 +756,7 @@ let write () : (unit, error) result = ] in Eio.Flow.write flow banner; - Util.KDL.to_flow flow mnfst; + KDL.to_flow flow mnfst; Eio.Flow.write flow ([Cstruct.of_string "\n"]) in Logs.app (fun m -> m "Manifest written."); diff --git a/lib/nixtamal.ml b/lib/nixtamal.ml index 5a27232..f8b9203 100644 --- a/lib/nixtamal.ml +++ b/lib/nixtamal.ml @@ -9,7 +9,7 @@ module Lockfile = Lockfile module Input = Input module Input_foreman = Input_foreman module Working_directory = Working_directory -module Util = Util +module KDL = KDL type error = Error.error @@ -45,11 +45,11 @@ let read_manifest_and_lockfile () : (Name.Name.t list, error) result = let* manifest = Error.tag_manifest @@ begin match Manifest.read () with - | Ok(kdl : Kdl.t) -> + | Ok(kdl : KDL.t) -> Manifest.document_to_t kdl |> Result.map_error (fun err -> `Parsing err) - | Error(e : Kdl.error) -> - let v_errs : Util.KDL.Valid.err list = [`ParseError e] in + | Error(e : KDL.error) -> + let v_errs : KDL.Valid.err list = [`ParseError e] in Error (`Parsing v_errs) end in diff --git a/lib/util.ml b/lib/util.ml index 02b2ea2..b76a789 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -68,97 +68,6 @@ module Jsont = struct | Error err -> Error err end -module KDL = struct - let of_flow flow = - try - Eio.Buf_read.parse_exn - (fun buf -> Eio.Buf_read.take_all buf |> Kdl.of_string) - ~max_size: max_int - flow - with - | exn -> failwith (Printexc.to_string exn) - - let to_flow flow doc = - Eio.Buf_write.with_flow flow @@ fun buf -> - let out_string s off len = - String.sub s off len |> Eio.Buf_write.string buf - in - let flush () = () in - let ppf = Format.make_formatter out_string flush in - - (* replace spaces with tabs for indentation *) - let base_fmt = Format.pp_get_formatter_out_functions ppf () in - let tabbed_fmt = {base_fmt with - out_indent = (fun n -> base_fmt.out_string (String.make n '\t') 0 n) - } - in - Format.pp_set_formatter_out_functions ppf tabbed_fmt; - - (* enable utf-8 and pretty-print *) - Fmt.set_utf_8 ppf true; - Kdl.pp ppf doc; - Format.pp_print_flush ppf () - - module L = Kdl_lens_result - - module Valid = struct - type err = [ - | L.lerr - | `ParseError of Kdl.error - | `OneRequired of string list - | `OnlyOneOf of string list - | `InvalidLatestCmd of string - | `InvalidHashAlgorithm of string - ] - [@@deriving show] - type 'a t = ('a, err list) result - let pp ~(ok : 'a Fmt.t) : 'a t Fmt.t = - Fmt.result ~ok ~error: (Fmt.list pp_err) - let map = Result.map - let map1 (f : 'a -> 'b) (vx : ('a, err) result) : 'b t = - match vx with - | Ok x -> Ok (f x) - | Error e -> Error [e] - let map_error = Result.map_error - let pure x = Ok x - let and_map (vx : 'a t) (vf : ('a -> 'b) t) = - match vx, vf with - | Ok x, Ok f -> Ok (f x) - | Error e, Ok _ -> Error e - | Ok _, Error e -> Error e - | Error e1, Error e2 -> Error (e2 @ e1) - let product (vx : 'a t) (vy : 'b t) = - match vx, vy with - | Ok x, Ok y -> Ok (x, y) - | Error e, Ok _ -> Error e - | Ok _, Error e -> Error e - | Error e1, Error e2 -> Error (e2 @ e1) - let and_map1 (vx : ('a, err) result) (vf : ('a -> 'b) t) = - match vx, vf with - | Ok x, Ok f -> Ok (f x) - | Error e, Ok _ -> Error [e] - | Ok _, Error e -> Error e - | Error e1, Error e2 -> Error (e2 @ [e1]) - let bind = Result.bind - let lift_lens (r : ('a, L.lerr) result) : ('a, err list) result = - Result.map_error (fun e -> ([e] :> err list)) r - let ll = lift_lens - let (let+) vx f = map f vx - let (and+) = product - let (let*) = bind - end - - type 'a codec = { - to_kdl: 'a -> Kdl.t; - of_kdl: Kdl.t -> 'a Valid.t - } - - type 'a node_codec = { - to_node: 'a -> Kdl.node; - of_node: Kdl.node -> 'a Valid.t - } -end - module These = struct type ('a, 'b) t = | This of 'a diff --git a/test/test_input.ml b/test/test_input.ml index 92eb308..ccfd595 100644 --- a/test/test_input.ml +++ b/test/test_input.ml @@ -7,7 +7,7 @@ open Nixtamal let suite = [test_case "Manifest latest-cmd to KDL" `Quick (fun () -> - let kdl = testable Kdl.pp Kdl.equal in + let kdl = testable KDL.pp KDL.equal in let open Nixtamal.Input.Latest.Cmd in let t = Input.Template.make in let in_kdl = @@ -23,7 +23,7 @@ let suite = | head -n1 } |} - |> Kdl.of_string + |> KDL.of_string |> Result.get_ok in check kdl "KDL latest-cmd with pipe" out_kdl in_kdl @@ -40,12 +40,12 @@ let suite = | head -n1 } |} - |> Kdl.of_string + |> KDL.of_string |> Result.get_ok in match Manifest.Latest_cmd.codec.of_kdl kdl with | Ok lc -> lc - | Error err -> failwith Fmt.(str "%a from %a" (list ~sep: semi Util.KDL.Valid.pp_err) err Kdl.pp kdl) + | Error err -> failwith Fmt.(str "%a from %a" (list ~sep: semi KDL.Valid.pp_err) err KDL.pp kdl) in let out_latest_cmd = ~${prog = t "curl"; args = [t "https://toast.al"]} @@ -55,7 +55,7 @@ let suite = check latest_cmd "latest-cmd with pipe from KDL" out_latest_cmd in_latest_cmd ); test_case "Manifest frozen Pijul to KDL" `Quick (fun () -> - let kdl = testable Kdl.pp Kdl.equal in + let kdl = testable KDL.pp KDL.equal in let t = Input.Template.make in let in_kdl = let name = Name.Name.make "pijul" @@ -74,15 +74,15 @@ let suite = } } |} - |> Kdl.of_string + |> KDL.of_string |> Result.get_ok in check kdl "KDL frozen Pijul" out_kdl [in_kdl] ); test_case "Manifest frozen Pijul of KDL" `Quick (fun () -> let input = testable Manifest.Input'.pp Manifest.Input'.equal in - let open Util.KDL.L in - let open Util.KDL.Valid in + let open KDL.L in + let open KDL.Valid in let t = Input.Template.make in let in_input = let kdl = @@ -94,13 +94,13 @@ let suite = } } |} - |> Kdl.of_string + |> KDL.of_string |> Result.get_ok in let node = ll @@ kdl.@(node "pijul" ~nth: 0) in match Result.bind node Manifest.Input'.codec.of_node with | Ok lc -> lc - | Error err -> failwith Fmt.(str "%a from %a" (list ~sep: semi Util.KDL.Valid.pp_err) err Kdl.pp kdl) + | Error err -> failwith Fmt.(str "%a from %a" (list ~sep: semi KDL.Valid.pp_err) err KDL.pp kdl) in let out_input = let name = Name.Name.make "pijul" @@ -151,7 +151,7 @@ let suite = Manifest.Input'.pp input' | Error err -> - QCheck.Test.fail_reportf "%a" Fmt.(list ~sep: semi Util.KDL.Valid.pp_err) err; + QCheck.Test.fail_reportf "%a" Fmt.(list ~sep: semi KDL.Valid.pp_err) err; ); QCheck.Test.make ~name: "Input sameshape" -- cgit v1.2.3