[OCaml] High Intensity Training Online
refactor extract calendar arithmetic
Changed files
lib/web/calendar.ml
@@ -0,0 +1,27 @@
1
Added:
let is_leap year = (year mod 4 = 0 && year mod 100 <> 0) || year mod 400 = 0
2
Added:
3
Added:
let days_in_month ~year ~month =
4
Added:
match month with
5
Added:
| 1 | 3 | 5 | 7 | 8 | 10 | 12 -> 31
6
Added:
| 4 | 6 | 9 | 11 -> 30
7
Added:
| 2 -> if is_leap year then 29 else 28
8
Added:
| _ -> invalid_arg "Calendar.days_in_month: month"
9
Added:
10
Added:
(* The weekday of a given UTC date, 0 = Monday .. 6 = Sunday. This uses Howard
11
Added:
Hinnant's day-count from the epoch. The count needs no timezone-aware libc
12
Added:
call, because [timegm] is not in the stdlib. *)
13
Added:
let monday_first_weekday ~year ~month ~day =
14
Added:
if month < 1 || month > 12 then
15
Added:
invalid_arg "Calendar.monday_first_weekday: month";
16
Added:
let year = if month <= 2 then year - 1 else year in
17
Added:
let era = (if year >= 0 then year else year - 399) / 400 in
18
Added:
let year_of_era = year - (era * 400) in
19
Added:
let day_of_year =
20
Added:
(((153 * if month > 2 then month - 3 else month + 9) + 2) / 5) + day - 1
21
Added:
in
22
Added:
let day_of_era =
23
Added:
(year_of_era * 365) + (year_of_era / 4) - (year_of_era / 100) + day_of_year
24
Added:
in
25
Added:
let days = (era * 146097) + day_of_era - 719468 in
26
Added:
(* 1970-01-01 is a Thursday = 3 in Monday-first indexing. *)
27
Added:
((((days mod 7) + 3) mod 7) + 7) mod 7
lib/web/calendar.mli
@@ -0,0 +1,10 @@
1
Added:
(** Gregorian calendar arithmetic for logbook views. *)
2
Added:
3
Added:
val is_leap : int -> bool
4
Added:
5
Added:
val days_in_month : year:int -> month:int -> int
6
Added:
(** Raises [Invalid_argument] when [month] is outside 1 to 12. *)
7
Added:
8
Added:
val monday_first_weekday : year:int -> month:int -> day:int -> int
9
Added:
(** Returns 0 for Monday through 6 for Sunday. Raises [Invalid_argument] when
10
Added:
[month] is outside 1 to 12. *)
lib/web/dune
@@ -39,6 +39,7 @@
39
39
(name hito_web)
40
40
(public_name hito.web)
41
41
(modules
42
Added:
calendar
42
43
decode
43
44
handlers_assets
44
45
handlers_kit
lib/web/handlers_logbook.ml
@@ -32,30 +32,6 @@
32
32
33
33
(* {1 Calendar} *)
34
34
35
Removed:
let is_leap y = (y mod 4 = 0 && y mod 100 <> 0) || y mod 400 = 0
36
Removed:
37
Removed:
let days_in_month ~year ~month =
38
Removed:
match month with
39
Removed:
| 1 | 3 | 5 | 7 | 8 | 10 | 12 -> 31
40
Removed:
| 4 | 6 | 9 | 11 -> 30
41
Removed:
| 2 -> if is_leap year then 29 else 28
42
Removed:
| _ -> 30
43
Removed:
44
Removed:
(* The weekday of a given UTC date, 0 = Monday .. 6 = Sunday. This uses Howard
45
Removed:
Hinnant's day-count from the epoch. The count needs no timezone-aware libc
46
Removed:
call, because [timegm] is not in the stdlib. *)
47
Removed:
let monday_first_weekday ~year ~month ~day =
48
Removed:
let y = if month <= 2 then year - 1 else year in
49
Removed:
let era = (if y >= 0 then y else y - 399) / 400 in
50
Removed:
let yoe = y - (era * 400) in
51
Removed:
let doy =
52
Removed:
(((153 * if month > 2 then month - 3 else month + 9) + 2) / 5) + day - 1
53
Removed:
in
54
Removed:
let doe = (yoe * 365) + (yoe / 4) - (yoe / 100) + doy in
55
Removed:
let days = (era * 146097) + doe - 719468 in
56
Removed:
(* 1970-01-01 is a Thursday = 3 in Monday-first indexing. *)
57
Removed:
((((days mod 7) + 3) mod 7) + 7) mod 7
58
Removed:
59
35
type planned_workout = { at_unix : int; workout_name : string }
60
36
61
37
let latest_finished_workout log =
@@ -129,8 +105,8 @@
129
105
else None)
130
106
planned
131
107
in
132
Removed:
let total = days_in_month ~year ~month in
133
Removed:
let lead = monday_first_weekday ~year ~month ~day:1 in
108
Added:
let total = Calendar.days_in_month ~year ~month in
109
Added:
let lead = Calendar.monday_first_weekday ~year ~month ~day:1 in
134
110
let cells =
135
111
List.init lead (fun _ -> View_model.Calendar.Blank)
136
112
@ List.init total (fun i ->
test/test_calendar.ml
@@ -0,0 +1,48 @@
1
Added:
module Calendar = Hito_web.Calendar
2
Added:
3
Added:
let invalid_month f =
4
Added:
try
5
Added:
ignore (f ());
6
Added:
false
7
Added:
with Invalid_argument _ -> true
8
Added:
9
Added:
let suite =
10
Added:
[
11
Added:
( "calendar",
12
Added:
[
13
Added:
( "recognizes Gregorian leap years",
14
Added:
`Quick,
15
Added:
fun () ->
16
Added:
Alcotest.(check bool)
17
Added:
"1900 is not leap" false (Calendar.is_leap 1900);
18
Added:
Alcotest.(check bool) "2000 is leap" true (Calendar.is_leap 2000);
19
Added:
Alcotest.(check bool) "2024 is leap" true (Calendar.is_leap 2024) );
20
Added:
( "counts every month",
21
Added:
`Quick,
22
Added:
fun () ->
23
Added:
let expected = [ 31; 29; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 ] in
24
Added:
List.iteri
25
Added:
(fun index days ->
26
Added:
Alcotest.(check int)
27
Added:
(Printf.sprintf "month %d" (index + 1))
28
Added:
days
29
Added:
(Calendar.days_in_month ~year:2024 ~month:(index + 1)))
30
Added:
expected );
31
Added:
( "rejects an invalid month",
32
Added:
`Quick,
33
Added:
fun () ->
34
Added:
Alcotest.(check bool)
35
Added:
"month 13" true
36
Added:
(invalid_month (fun () ->
37
Added:
Calendar.days_in_month ~year:2024 ~month:13)) );
38
Added:
( "returns Monday-first weekdays",
39
Added:
`Quick,
40
Added:
fun () ->
41
Added:
Alcotest.(check int)
42
Added:
"1970-01-01 was Thursday" 3
43
Added:
(Calendar.monday_first_weekday ~year:1970 ~month:1 ~day:1);
44
Added:
Alcotest.(check int)
45
Added:
"2024-01-01 was Monday" 0
46
Added:
(Calendar.monday_first_weekday ~year:2024 ~month:1 ~day:1) );
47
Added:
] );
48
Added:
]
test/test_hito.ml
@@ -12,7 +12,8 @@
12
12
@ Test_workout_import.suite @ Test_import_service.suite @ Test_codec.suite
13
13
@ Test_import_codec.suite @ Test_import_repo.suite @ Test_import_sqlite.suite
14
14
@ Test_bcrypt_hash.suite @ Test_sqlite_repo.suite
15
Removed:
@ Test_development_seed.suite @ Test_decode.suite @ Test_hevy_csv.suite
16
Removed:
@ Web.Auth.suite @ Web.Overview.suite @ Web.Workout.suite @ Web.Logbook.suite
17
Removed:
@ Web.App_feedback.suite @ Web.Profile.suite @ Web.Import.suite
18
Removed:
@ Web.Errors.suite @ Web.Isolation.suite)
15
Added:
@ Test_development_seed.suite @ Test_decode.suite @ Test_calendar.suite
16
Added:
@ Test_hevy_csv.suite @ Web.Auth.suite @ Web.Overview.suite
17
Added:
@ Web.Workout.suite @ Web.Logbook.suite @ Web.App_feedback.suite
18
Added:
@ Web.Profile.suite @ Web.Import.suite @ Web.Errors.suite
19
Added:
@ Web.Isolation.suite)