1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
|
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
toward zero, which the negative-branch adjustments account for. *)
type t = int
let days_from_civil y m d =
let y = if m <= 2 then y - 1 else y in
let era = (if y >= 0 then y else y - 399) / 400 in
let yoe = y - (era * 400) in
let doy = ((153 * (if m > 2 then m - 3 else m + 9)) + 2) / 5 + (d - 1) in
let doe = (yoe * 365) + (yoe / 4) - (yoe / 100) + doy in
(era * 146097) + doe - 719468
let civil_from_days z =
let z = z + 719468 in
let era = (if z >= 0 then z else z - 146096) / 146097 in
let doe = z - (era * 146097) in
let yoe = (doe - (doe / 1460) + (doe / 36524) - (doe / 146096)) / 365 in
let y = yoe + (era * 400) in
let doy = doe - ((365 * yoe) + (yoe / 4) - (yoe / 100)) in
let mp = ((5 * doy) + 2) / 153 in
let d = doy - (((153 * mp) + 2) / 5) + 1 in
let m = if mp < 10 then mp + 3 else mp - 9 in
((if m <= 2 then y + 1 else y), m, d)
let year t = let y, _, _ = civil_from_days t in y
let month t = let _, m, _ = civil_from_days t in m
let day t = let _, _, d = civil_from_days t in d
let is_leap y = (y mod 4 = 0 && y mod 100 <> 0) || y mod 400 = 0
let days_in_month y m =
match m with
| 1 | 3 | 5 | 7 | 8 | 10 | 12 -> 31
| 4 | 6 | 9 | 11 -> 30
| 2 -> if is_leap y then 29 else 28
| _ -> 0
let make ~year ~month ~day =
if year < 1583 || year > 9999 then
Error (Printf.sprintf "year %d out of range 1583..9999" year)
else if month < 1 || month > 12 then
Error (Printf.sprintf "month %d out of range 1..12" month)
else if day < 1 || day > days_in_month year month then
Error (Printf.sprintf "day %d out of range for %04d-%02d" day year month)
else Ok (days_from_civil year month day)
let to_rata t = t
let of_rata z = z
let add_days t n = t + n
let compare = Int.compare
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
|
