kernel: Slug and Lang validated private strings

Both parse through a smart constructor returning result, and both hand-write
t_of_sexp so a malformed value in a data file is rejected at load rather than
silently accepted -- deriving the converter would have bypassed validation.

4 files changed, 79 insertions, 0 deletions

diff --git a/lib/kernel/lang.ml b/lib/kernel/lang.ml
new file mode 100644
index 0000000..3f45f59
--- /dev/null
+++ b/lib/kernel/lang.ml
@@ -0,0 +1,23 @@
+(* Language codes for celebration names. Two-letter lowercase ISO-639-1; the set
+   is open so an overlay can add a language without a code change (spec §2.1). *)
+type t = string
+
+let of_string s =
+  if String.length s <> 2 then
+    Error (Printf.sprintf "lang %S: expected a 2-letter ISO-639-1 code" s)
+  else if not (String.for_all (fun c -> c >= 'a' && c <= 'z') s) then
+    Error (Printf.sprintf "lang %S: must be lowercase a-z" s)
+  else Ok s
+
+let of_string_exn s = match of_string s with Ok t -> t | Error e -> invalid_arg e
+let to_string t = t
+let compare = String.compare
+let equal = String.equal
+
+let sexp_of_t t = Sexplib0.Sexp_conv.sexp_of_string t
+
+let t_of_sexp sexp =
+  let s = Sexplib0.Sexp_conv.string_of_sexp sexp in
+  match of_string s with
+  | Ok t -> t
+  | Error msg -> Sexplib0.Sexp_conv.of_sexp_error msg sexp
diff --git a/lib/kernel/lang.mli b/lib/kernel/lang.mli
new file mode 100644
index 0000000..6d26a1d
--- /dev/null
+++ b/lib/kernel/lang.mli
@@ -0,0 +1,11 @@
+(** Two-letter lowercase ISO-639-1 language codes. The set is deliberately open:
+    overlays add languages as data, never as code. *)
+type t = private string
+
+val of_string : string -> (t, string) result
+val of_string_exn : string -> t
+val to_string : t -> string
+val compare : t -> t -> int
+val equal : t -> t -> bool
+val t_of_sexp : Sexplib0.Sexp.t -> t
+val sexp_of_t : t -> Sexplib0.Sexp.t
diff --git a/lib/kernel/slug.ml b/lib/kernel/slug.ml
new file mode 100644
index 0000000..5139c99
--- /dev/null
+++ b/lib/kernel/slug.ml
@@ -0,0 +1,29 @@
+(* Stable celebration identifiers. Also the lectionary key: EF slugs are adopted
+   verbatim from lectio so the Plan 3 lectionary bootstrap needs no mapping
+   table (spec §4.4). *)
+type t = string
+
+let valid_char c = (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c = '-'
+
+let of_string s =
+  if String.length s = 0 then Error "slug: empty"
+  else if not (String.for_all valid_char s) then
+    Error (Printf.sprintf "slug %S: only [a-z0-9-] allowed" s)
+  else if s.[0] = '-' || s.[String.length s - 1] = '-' then
+    Error (Printf.sprintf "slug %S: must not start or end with '-'" s)
+  else Ok s
+
+let of_string_exn s = match of_string s with Ok t -> t | Error e -> invalid_arg e
+let to_string t = t
+let compare = String.compare
+let equal = String.equal
+
+let sexp_of_t t = Sexplib0.Sexp_conv.sexp_of_string t
+
+(* Validating parser: a malformed slug in a data file is an error, never a
+   silently-accepted value. Loaders convert the exception to a [result]. *)
+let t_of_sexp sexp =
+  let s = Sexplib0.Sexp_conv.string_of_sexp sexp in
+  match of_string s with
+  | Ok t -> t
+  | Error msg -> Sexplib0.Sexp_conv.of_sexp_error msg sexp
diff --git a/lib/kernel/slug.mli b/lib/kernel/slug.mli
new file mode 100644
index 0000000..0081e2b
--- /dev/null
+++ b/lib/kernel/slug.mli
@@ -0,0 +1,16 @@
+(** Stable celebration identifiers: non-empty [a-z0-9-], no leading or trailing
+    hyphen. Also serve as lectionary keys. *)
+type t = private string
+
+val of_string : string -> (t, string) result
+
+(** For literals in code and tests. Raises [Invalid_argument] on a bad slug. *)
+val of_string_exn : string -> t
+
+val to_string : t -> string
+val compare : t -> t -> int
+val equal : t -> t -> bool
+
+(** Validating; raises [Of_sexp_error] on a malformed slug. *)
+val t_of_sexp : Sexplib0.Sexp.t -> t
+val sexp_of_t : t -> Sexplib0.Sexp.t