diff options
| author | Lukasz Kasprzak <lukas@labunix.xyz> | 2026-08-11 11:15:18 +0200 |
|---|---|---|
| committer | Lukasz Kasprzak <lukas@labunix.xyz> | 2026-08-11 11:15:18 +0200 |
| commit | d532c3b2cf941d2fe0c3c84f2c4090f14e869ef0 (patch) | |
| tree | ba8f4bb56157989d5874ede8ae463a36812c0001 | |
| parent | 1d6b9a540a50159221e0475bc1c1c2387d417622 (diff) | |
| download | colitur-d532c3b2cf941d2fe0c3c84f2c4090f14e869ef0.tar.gz colitur-d532c3b2cf941d2fe0c3c84f2c4090f14e869ef0.zip | |
kernel(date): ISO-8601 rendering, validating parse, sexp converters
Adds sexplib and ppx_sexp_conv to the project and wires the ppx into the
kernel library. Date's sexp form is an ISO-8601 atom rather than the opaque
rata die, so data files stay human-editable and parsing revalidates the
1583..9999 domain.
| -rw-r--r-- | colitur.opam | 2 | ||||
| -rw-r--r-- | dune-project | 2 | ||||
| -rw-r--r-- | lib/kernel/date.ml | 25 | ||||
| -rw-r--r-- | lib/kernel/date.mli | 15 | ||||
| -rw-r--r-- | lib/kernel/dune | 5 | ||||
| -rw-r--r-- | test/dune | 2 | ||||
| -rw-r--r-- | test/test_date.ml | 19 |
7 files changed, 64 insertions, 6 deletions
diff --git a/colitur.opam b/colitur.opam index d855e8e..3edcfa4 100644 --- a/colitur.opam +++ b/colitur.opam @@ -7,6 +7,8 @@ depends: [ "alcotest" "qcheck" "qcheck-alcotest" + "sexplib" + "ppx_sexp_conv" "odoc" {with-doc} ] build: [ diff --git a/dune-project b/dune-project index cd3af07..91824f4 100644 --- a/dune-project +++ b/dune-project @@ -6,4 +6,4 @@ (package (name colitur) (synopsis "Deterministic liturgical calendar engine (computus liturgicus)") - (depends ocaml dune alcotest qcheck qcheck-alcotest)) + (depends ocaml dune alcotest qcheck qcheck-alcotest sexplib ppx_sexp_conv)) diff --git a/lib/kernel/date.ml b/lib/kernel/date.ml index 525b35b..cf5aabd 100644 --- a/lib/kernel/date.ml +++ b/lib/kernel/date.ml @@ -1,4 +1,4 @@ -type weekday = Sun | Mon | Tue | Wed | Thu | Fri | Sat +type weekday = Sun | Mon | Tue | Wed | Thu | Fri | Sat [@@deriving sexp] (* Internal representation: rata die = days since 1970-01-01 (proleptic Gregorian). Howard Hinnant's civil<->days algorithm; OCaml's `/` truncates @@ -56,3 +56,26 @@ let weekday t = (* rata 0 = 1970-01-01 = Thursday (index 4 with Sun=0). *) let w = (((t + 4) mod 7) + 7) mod 7 in [| Sun; Mon; Tue; Wed; Thu; Fri; Sat |].(w) + +let weekday_to_string = function + | Sun -> "sunday" | Mon -> "monday" | Tue -> "tuesday" | Wed -> "wednesday" + | Thu -> "thursday" | Fri -> "friday" | Sat -> "saturday" + +let to_iso8601 t = Printf.sprintf "%04d-%02d-%02d" (year t) (month t) (day t) + +let of_iso8601 s = + match String.split_on_char '-' s with + | [ y; m; d ] + when String.length y = 4 && String.length m = 2 && String.length d = 2 -> ( + match (int_of_string_opt y, int_of_string_opt m, int_of_string_opt d) with + | Some year, Some month, Some day -> make ~year ~month ~day + | _ -> Error (Printf.sprintf "date %S: not an ISO-8601 date" s)) + | _ -> Error (Printf.sprintf "date %S: expected YYYY-MM-DD" s) + +let sexp_of_t t = Sexplib0.Sexp_conv.sexp_of_string (to_iso8601 t) + +let t_of_sexp sexp = + let s = Sexplib0.Sexp_conv.string_of_sexp sexp in + match of_iso8601 s with + | Ok t -> t + | Error msg -> Sexplib0.Sexp_conv.of_sexp_error msg sexp diff --git a/lib/kernel/date.mli b/lib/kernel/date.mli index b684d61..2f632c8 100644 --- a/lib/kernel/date.mli +++ b/lib/kernel/date.mli @@ -3,7 +3,7 @@ arithmetic and comparison are total and cheap. *) type t -type weekday = Sun | Mon | Tue | Wed | Thu | Fri | Sat +type weekday = Sun | Mon | Tue | Wed | Thu | Fri | Sat [@@deriving sexp] (** [make ~year ~month ~day] validates the date; rejects a month/day out of range and any year outside 1583..9999. *) @@ -21,3 +21,16 @@ val to_rata : t -> int val of_rata : int -> t val add_days : t -> int -> t val compare : t -> t -> int + +(** ISO-8601 rendering and validating parsing. [of_iso8601] enforces the same + domain as {!make}. *) +val to_iso8601 : t -> string +val of_iso8601 : string -> (t, string) result + +val weekday_to_string : weekday -> string + +(** Sexp form is an ISO-8601 atom, e.g. [2026-04-05]. [t_of_sexp] validates and + raises [Of_sexp_error] on a malformed or out-of-domain date; loaders convert + that to a [result]. *) +val t_of_sexp : Sexplib0.Sexp.t -> t +val sexp_of_t : t -> Sexplib0.Sexp.t diff --git a/lib/kernel/dune b/lib/kernel/dune index b63c476..b909ac5 100644 --- a/lib/kernel/dune +++ b/lib/kernel/dune @@ -1,2 +1,5 @@ (library - (name colitur_kernel)) + (name colitur_kernel) + (libraries sexplib) + (preprocess + (pps ppx_sexp_conv))) @@ -1,6 +1,6 @@ (test (name test_colitur) - (libraries colitur_kernel alcotest qcheck qcheck-alcotest)) + (libraries colitur_kernel alcotest qcheck qcheck-alcotest sexplib)) (cram (deps %{bin:colitur})) diff --git a/test/test_date.ml b/test/test_date.ml index 2458659..e3c2dfb 100644 --- a/test/test_date.ml +++ b/test/test_date.ml @@ -52,11 +52,28 @@ let prop_weekday_cycle = QCheck.Test.make ~name:"weekday(add_days d 7) = weekday d" arb_date (fun d -> D.weekday (D.add_days d 7) = D.weekday d) +let test_iso8601 () = + Alcotest.(check string) "to_iso8601" "2026-04-05" (D.to_iso8601 (mk 2026 4 5)); + (match D.of_iso8601 "2026-04-05" with + | Ok d -> Alcotest.(check int) "of_iso8601 roundtrip" 0 (D.compare d (mk 2026 4 5)) + | Error e -> Alcotest.failf "of_iso8601: %s" e); + Alcotest.(check bool) "reject garbage" true (Result.is_error (D.of_iso8601 "nope")); + Alcotest.(check bool) "reject 2026-02-30" true (Result.is_error (D.of_iso8601 "2026-02-30")) + +let test_date_sexp () = + let d = mk 2026 4 5 in + Alcotest.(check string) "sexp_of_t" "2026-04-05" (Sexplib.Sexp.to_string (D.sexp_of_t d)); + Alcotest.(check int) "t_of_sexp roundtrip" 0 + (D.compare (D.t_of_sexp (D.sexp_of_t d)) d); + Alcotest.(check string) "weekday_to_string" "sunday" (D.weekday_to_string (D.weekday d)) + let suite = ( "Date", [ Alcotest.test_case "weekday" `Quick test_weekday; Alcotest.test_case "roundtrip" `Quick test_roundtrip; Alcotest.test_case "add_days boundaries" `Quick test_add_days; - Alcotest.test_case "make rejects invalid" `Quick test_make_reject ] + Alcotest.test_case "make rejects invalid" `Quick test_make_reject; + Alcotest.test_case "iso8601" `Quick test_iso8601; + Alcotest.test_case "sexp" `Quick test_date_sexp ] @ List.map QCheck_alcotest.to_alcotest [ prop_roundtrip; prop_add_inverse; prop_weekday_cycle ] ) |
