path: root/lib/kDL_lens_result.ml

(*─────────────────────────────────────────────────────────────────────────────┐
│ SPDX-FileCopyrightText: eilveli                                              │
│ SPDX-FileContributor: toastal <toastal@posteo.net>                           │
│ SPDX-License-Identifier: MPL-2.0                                             │
│                                                                              │
│ Upstream: https://github.com/eilvelia/ocaml-kdl                              │
│ Purpose: address “note: we can possibly replace option with result for more  │
│ detailed errors”                                                             │
│                                                                              │
│ Short-comings: no ‘trail’ for the errors & not extensible with user-defined  │
│ errors with ('a, 'b, 'err) proving difficult to work with                    │
└─────────────────────────────────────────────────────────────────────────────*)

type lerr = [
	| `Cannot_each
	| `Cannot_replace
	| `Missing_annot
	| `Missing_index of int
	| `Missing_prop of string
	| `Missing_top
	| `Not_found of string * string option
	| `Mismatched_type
	| `Wrong_type_bool
	| `Wrong_type_float
	| `Wrong_type_Int
	| `Wrong_type_Int32
	| `Wrong_type_Int64
	| `Wrong_type_native_int
	| `Wrong_type_null
	| `Wrong_type_number
	| `Wrong_type_string
	| `Wrong_type_stringNumber
]
[@@deriving show]

let pp_lerr fmt = function
	| `Cannot_each -> 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)