aboutsummaryrefslogtreecommitdiffstats
path: root/lib/condition.ml
diff options
context:
space:
mode:
authorEstevan Castilho <tevo@riajuu.net>2026-05-27 23:24:12 +0000
committerGitHub <noreply@github.com>2026-05-27 23:24:12 +0000
commit9dc0391443ca16bf1ab3114d002aad83872f8a73 (patch)
treee4f78a2533e5e633b733c1ea21d0159aeca79b75 /lib/condition.ml
parentf9097a0562ea8b40d40a19059578a9280b945de4 (diff)
downloadSakura-9dc0391443ca16bf1ab3114d002aad83872f8a73.tar.gz
Sakura-9dc0391443ca16bf1ab3114d002aad83872f8a73.zip
Improve the error handling situation (#71)
* Sketches of a condition system * `Condition.condition` -> `Condition.t` * Migrate `NT` over * Migrate `Branch` over * Migrate `Sublanguage` et al. over * Migrate the PRL over * Migrate the DRL over * Migrate the DML over * Have `Qualified_name.try_parse` return a `Condition.t` * Migrate the DDL over * Migrate the VCL over * Migrate the SCL over * Migrate the ICL over * Migrate the parsers over * Just inherit the errors from NT and the sublanguages * Migrate `Management.Physical` over * Migrate `Configuration` over * Migrate `Management.Branch` over * Migrate `Transport` over * Migrate `System` over * Migrate `Server` over * Include messages on on all conditions * A prettier stringifier
Diffstat (limited to '')
-rw-r--r--lib/condition.ml49
1 files changed, 49 insertions, 0 deletions
diff --git a/lib/condition.ml b/lib/condition.ml
new file mode 100644
index 0000000..44ef2ff
--- /dev/null
+++ b/lib/condition.ml
@@ -0,0 +1,49 @@
+
+class type serializable = object
+ method as_sexp : Sexplib.Sexp.t
+ method as_string : string
+end
+
+class literal (expr : Sexplib.Sexp.t) : serializable = object
+ method as_sexp = expr
+ method as_string = Sexplib.Sexp.to_string_hum expr
+end
+
+let of_sexp (expr : Sexplib.Sexp.t) = new literal expr
+let of_string (s : string) = new literal (Sexplib.Sexp.Atom s)
+let of_list (f : 'a -> serializable) (l : 'a list) : serializable =
+ new literal (Sexplib.Sexp.List (List.map (fun e -> (f e)#as_sexp) l))
+
+type t = { name : string;
+ message : string;
+ properties : (string, serializable) BatMap.t }
+
+let condition name message ?parent props =
+ { name;
+ message;
+ properties =
+ parent
+ |> Option.map (fun { properties; _ } -> properties)
+ |> Option.value ~default:BatMap.empty
+ |> props }
+
+let ( |=| ) name value = (fun p -> BatMap.add name value p)
+let ( & ) l r = (fun p -> r (l p))
+let empty = (fun p -> p)
+
+let to_sexp { name; message; properties } =
+ let open Sexplib.Sexp in
+ let properties' =
+ properties
+ |> BatMap.to_seq
+ |> BatSeq.map (fun (k, v) -> List [Atom k; v#as_sexp])
+ |> BatList.of_seq in
+ List (Atom name :: Atom message :: properties')
+
+let to_string { name; message; properties } =
+ let properties' =
+ properties
+ |> BatMap.to_seq
+ |> BatSeq.to_string ~sep:"\n" (fun (k, v) -> "\t" ^ k ^ ": " ^ v#as_string)
+ in
+ name ^ ": " ^ message ^ properties'