diff --git docker/Dockerfile docker/Dockerfile index 804a056808..375ac746e2 100644 --- docker/Dockerfile +++ docker/Dockerfile @@ -19,7 +19,7 @@ RUN export DEBIAN_FRONTEND=noninteractive \ # Update local opam repository USER opam WORKDIR /home/opam/opam-repository -RUN git fetch origin master && git checkout 21f97b2e6d7c617fc0a79cc8e59b2e10690960e1 && opam update +RUN git fetch origin master && git checkout a4ce2314f5990609c9ee2133734cc49d9606646f && opam update # Initialize OPAM WORKDIR /home/opam diff --git dune-project dune-project index de8b6969ed..ae18e95742 100644 --- dune-project +++ dune-project @@ -21,7 +21,7 @@ (ocaml (>= 4.10)) (alcotest :with-test) benchmark - (calendars (= "1.0.0")) + (calendars (>= "2.0.0")) (camlp5 (>= "8.03.00")) camlp-streams cppo diff --git geneweb.opam geneweb.opam index 4b68b077d0..3a2d20e2f0 100644 --- geneweb.opam +++ geneweb.opam @@ -15,7 +15,7 @@ depends: [ "ocaml" {>= "4.10"} "alcotest" {with-test} "benchmark" - "calendars" {= "1.0.0"} + "calendars" {>= "2.0.0"} "camlp5" {>= "8.03.00"} "camlp-streams" "cppo" diff --git geneweb_colab.ipynb geneweb_colab.ipynb index 00480d625c..49f786fbce 100644 --- geneweb_colab.ipynb +++ geneweb_colab.ipynb @@ -75,7 +75,7 @@ "!opam -y init --bare --shell-setup\n", "!opam switch create 4.14.2\n", "!eval $(opam env --switch=4.14.2)\n", - "!opam install -y calendars.1.0.0 camlp-streams camlp5 cppo decompress digestif dune jingoo markup oUnit pp_loc ppx_blob ppx_deriving ppx_import stdlib-shims logs logs-syslog unidecode.0.2.0 uri uucp uutf uunf yojson" + "!opam install -y calendars.2.0.0 camlp-streams camlp5 cppo decompress digestif dune jingoo markup oUnit pp_loc ppx_blob ppx_deriving ppx_import stdlib-shims logs logs-syslog unidecode.0.2.0 uri uucp uutf uunf yojson" ] }, { diff --git lib/util/calendar.ml lib/util/calendar.ml index 050d485e72..3c84a59bff 100644 --- lib/util/calendar.ml +++ lib/util/calendar.ml @@ -1,29 +1,31 @@ -(* TODO this is probably buggy, - because geneweb uses month|day = 0 for incomplete dates *) -(** Convert [Adef.date] to Calendars.d *) -let to_calendars : Def.dmy -> Calendars.d = - fun { Def.day; month; year; delta; _ } -> { Calendars.day; month; year; delta } +let to_calendar_date kind { Def.day; month; year; delta; _ } = + let day = max 1 day in + let month = max 1 month in + match Calendars.make kind ~day ~month ~year ~delta with + | Ok d -> d + | Error err -> + failwith + (Printf.sprintf "Invalid date: %s" + (Calendars.Unsafe.to_string err.value)) -(** Convert Calendars.d to [Adef.date] *) -let of_calendars : ?prec:Def.precision -> Calendars.d -> Def.dmy = - fun ?(prec = Def.Sure) { Calendars.day; month; year; delta } -> +let of_calendars : type a. ?prec:Def.precision -> a Calendars.date -> Def.dmy = + fun ?(prec = Def.Sure) { Calendars.day; month; year; delta; _ } -> { Def.day; month; year; delta; prec } -let sdn_of_gregorian (d : Def.dmy) = - Calendars.sdn_of_gregorian @@ to_calendars d +let sdn_of_gregorian d = + Calendars.to_sdn (to_calendar_date Calendars.Gregorian d) let gregorian_of_sdn prec sdn = - of_calendars ~prec @@ Calendars.gregorian_of_sdn sdn + of_calendars ~prec (Calendars.gregorian_of_sdn sdn) -let sdn_of_julian (d : Def.dmy) = Calendars.sdn_of_julian @@ to_calendars d -let julian_of_sdn prec sdn = of_calendars ~prec @@ Calendars.julian_of_sdn sdn -let sdn_of_french (d : Def.dmy) = Calendars.sdn_of_french @@ to_calendars d -let french_of_sdn prec sdn = of_calendars ~prec @@ Calendars.french_of_sdn sdn -let sdn_of_hebrew (d : Def.dmy) = Calendars.sdn_of_hebrew @@ to_calendars d -let hebrew_of_sdn prec sdn = of_calendars ~prec @@ Calendars.hebrew_of_sdn sdn +let sdn_of_julian d = Calendars.to_sdn (to_calendar_date Calendars.Julian d) +let julian_of_sdn prec sdn = of_calendars ~prec (Calendars.julian_of_sdn sdn) +let sdn_of_french d = Calendars.to_sdn (to_calendar_date Calendars.French d) +let french_of_sdn prec sdn = of_calendars ~prec (Calendars.french_of_sdn sdn) +let sdn_of_hebrew d = Calendars.to_sdn (to_calendar_date Calendars.Hebrew d) +let hebrew_of_sdn prec sdn = of_calendars ~prec (Calendars.hebrew_of_sdn sdn) -let dmy_of_dmy2 : Def.dmy2 -> Def.dmy = - fun { Def.day2; month2; year2; delta2 } -> +let dmy_of_dmy2 { Def.day2; month2; year2; delta2 } = { Def.day = day2; month = month2; @@ -32,30 +34,47 @@ let dmy_of_dmy2 : Def.dmy2 -> Def.dmy = delta = delta2; } -let aux fn (d : Def.dmy) : Def.dmy = - let aux2 d2 = - let d = of_calendars @@ fn @@ to_calendars @@ dmy_of_dmy2 d2 in - { - Def.day2 = d.Def.day; - month2 = d.Def.month; - year2 = d.Def.year; - delta2 = d.Def.delta; - } +let convert_via_sdn from_sdn to_of_sdn d = + let convert_dmy2 d2 = + if d2.Def.day2 = 0 || d2.Def.month2 = 0 then d2 + else + let sdn = from_sdn (dmy_of_dmy2 d2) in + let c = of_calendars (to_of_sdn sdn) in + { + Def.day2 = c.Def.day; + month2 = c.Def.month; + year2 = c.Def.year; + delta2 = c.Def.delta; + } in let prec = match d.Def.prec with - | Def.OrYear d2 -> Def.OrYear (aux2 d2) - | Def.YearInt d2 -> Def.YearInt (aux2 d2) + | Def.OrYear d2 -> Def.OrYear (convert_dmy2 d2) + | Def.YearInt d2 -> Def.YearInt (convert_dmy2 d2) | prec -> prec in - of_calendars ~prec @@ fn @@ to_calendars d + if d.Def.day = 0 || d.Def.month = 0 then { d with Def.prec } + else + let sdn = from_sdn d in + of_calendars ~prec (to_of_sdn sdn) -let gregorian_of_julian = aux Calendars.gregorian_of_julian -let julian_of_gregorian = aux Calendars.julian_of_gregorian -let gregorian_of_french = aux Calendars.gregorian_of_french -let french_of_gregorian = aux Calendars.french_of_gregorian -let gregorian_of_hebrew = aux Calendars.gregorian_of_hebrew -let hebrew_of_gregorian = aux Calendars.hebrew_of_gregorian +let gregorian_of_julian d = + convert_via_sdn sdn_of_julian Calendars.gregorian_of_sdn d + +let julian_of_gregorian d = + convert_via_sdn sdn_of_gregorian Calendars.julian_of_sdn d + +let gregorian_of_french d = + convert_via_sdn sdn_of_french Calendars.gregorian_of_sdn d + +let french_of_gregorian d = + convert_via_sdn sdn_of_gregorian Calendars.french_of_sdn d + +let gregorian_of_hebrew d = + convert_via_sdn sdn_of_hebrew Calendars.gregorian_of_sdn d + +let hebrew_of_gregorian d = + convert_via_sdn sdn_of_gregorian Calendars.hebrew_of_sdn d type moon_phase = Calendars.moon_phase = | NewMoon diff --git lib/util/calendar.mli lib/util/calendar.mli index 344f4fc089..495d0c8249 100644 --- lib/util/calendar.mli +++ lib/util/calendar.mli @@ -1,3 +1,14 @@ +(* Calendar conversions using Calendars library (>= 2.0.0) + + This module wraps the external Calendars library to provide + conversions between Geneweb's Def.dmy type and Serial Day Numbers (SDN). + + SDN (Serial Day Number) is a day numbering system where: + - SDN 1 = November 25, 4714 BC (Gregorian proleptic) + - Enables calendar-neutral date arithmetic + - Used for inter-calendar conversions +*) + val gregorian_of_sdn : Def.precision -> int -> Def.dmy (** Returns date of gregorian calendar from SDN and specified precision. *) diff --git test/calendar_test.ml test/calendar_test.ml index 027e8f1b39..7cf52288de 100644 --- test/calendar_test.ml +++ test/calendar_test.ml @@ -1,6 +1,18 @@ -let data_sure = +let pp_dmy fmt d = + Format.fprintf fmt "{day=%d;month=%d;year=%d;delta=%d;prec=...}" d.Def.day + d.Def.month d.Def.year d.Def.delta + +let testable_dmy = Alcotest.testable pp_dmy ( = ) + +let data_complete = [ Def.{ day = 1; month = 1; year = 1900; delta = 0; prec = Sure }; + Def.{ day = 15; month = 6; year = 2000; delta = 0; prec = Sure }; + Def.{ day = 29; month = 2; year = 2000; delta = 0; prec = Sure }; + ] + +let data_partial = + [ Def.{ day = 0; month = 1; year = 1900; delta = 0; prec = Sure }; Def.{ day = 0; month = 0; year = 1900; delta = 0; prec = Sure }; ] @@ -36,59 +48,32 @@ let data_oryear = open Alcotest open Calendar -(* TODO Fmt *) -let testable_calendar = testable Fmt.nop ( = ) - let round_trip of_ to_ l () = let f d = of_ (to_ d) in - (* todo should iter in v? *) - List.iter (fun d -> (check testable_calendar) "" d (f d)) l + List.iter (fun d -> (check testable_dmy) "" d (f d)) l -let expect_failure name speed f = - Alcotest.test_case name speed (fun () -> - try - f (); - Alcotest.fail "Expected this test to fail, but it passed" - with _ -> ()) +let sdn_round_trip name of_sdn sdn_of = + test_case name `Quick (round_trip (of_sdn Def.Sure) sdn_of data_complete) let v = [ - ( (* this fail because Calendars library does not work on incomplete dates (day|month) = 0 *) - (* see issue 2172 *) - "calendar-sdn", + ( "calendar-sdn", [ - expect_failure "Calendar gregorian <-> sdn" `Quick - (round_trip (gregorian_of_sdn Def.Sure) sdn_of_gregorian data_sure); - expect_failure "Calendar julian <-> sdn" `Quick - (round_trip (julian_of_sdn Def.Sure) sdn_of_julian data_sure); - expect_failure "Calendar french <-> sdn" `Quick - (round_trip (french_of_sdn Def.Sure) sdn_of_french data_sure); - expect_failure "Calendar hebrew <-> sdn" `Quick - (round_trip (hebrew_of_sdn Def.Sure) sdn_of_hebrew data_sure); + sdn_round_trip "gregorian <-> sdn" gregorian_of_sdn sdn_of_gregorian; + sdn_round_trip "julian <-> sdn" julian_of_sdn sdn_of_julian; + sdn_round_trip "french <-> sdn" french_of_sdn sdn_of_french; + sdn_round_trip "hebrew <-> sdn" hebrew_of_sdn sdn_of_hebrew; ] ); - ( "calendar-greg", + ( "calendar-conv", [ - test_case "Calendar gregorian <-> julian" `Quick + test_case "gregorian <-> julian" `Quick (round_trip gregorian_of_julian julian_of_gregorian - (data_sure @ data_oryear)); - test_case "Calendar gregorian <-> french" `Quick + (data_complete @ data_partial @ data_oryear)); + test_case "gregorian <-> french" `Quick (round_trip gregorian_of_french french_of_gregorian - (data_sure @ data_oryear)); - test_case "Calendar gregorian <-> hebrew" `Quick + (data_complete @ data_partial @ data_oryear)); + test_case "gregorian <-> hebrew" `Quick (round_trip gregorian_of_hebrew hebrew_of_gregorian - (data_sure @ data_oryear)); + (data_complete @ data_partial @ data_oryear)); ] ); ] - -(* - -let suite = - [ - "Calendar" - >::: [] - (* @ (sdn_round_trip "gregorian" Calendar.sdn_of_gregorian Calendar.gregorian_of_sdn) - * @ (sdn_round_trip "julian" Calendar.sdn_of_julian Calendar.julian_of_sdn) - * @ (sdn_round_trip "french" Calendar.sdn_of_french Calendar.french_of_sdn) - * @ (sdn_round_trip "hebrew" Calendar.sdn_of_hebrew Calendar.hebrew_of_sdn) *) - ] - *)