├── .github └── CODEOWNERS ├── .gitignore ├── .travis.yml ├── CHANGES ├── CONFIGURE_HEADER ├── COPYING ├── HEADER ├── LGPL ├── LICENSE ├── Makefile ├── README.md ├── TODO ├── calendar.opam ├── calendarFAQ-2.6.txt ├── calendar_faq.txt ├── dune-project ├── headache_config.txt ├── man_date.txt ├── src ├── calendar.ml ├── calendar.mli ├── calendar_builder.ml ├── calendar_builder.mli ├── calendar_sig.mli ├── date.ml ├── date.mli ├── date_sig.mli ├── dune ├── fcalendar.ml ├── fcalendar.mli ├── ftime.ml ├── ftime.mli ├── period.mli ├── printer.ml ├── printer.mli ├── time.ml ├── time.mli ├── time_Zone.ml ├── time_Zone.mli ├── time_sig.mli ├── utils.ml ├── utils.mli └── version.mli ├── tests ├── dune ├── gen_test.ml ├── gen_test.mli ├── test.ml ├── test_calendar.ml ├── test_date.ml ├── test_fcalendar.ml ├── test_fpcalendar.ml ├── test_ftime.ml ├── test_pcalendar.ml ├── test_printer.ml ├── test_time.ml └── test_timezone.ml └── utils ├── example.ml.3 └── example.ml.4 /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | # These are the default owners for everything in the repo. They will 2 | # receive review requests when someone opens a pull request. 3 | * @Drup @loxs @pmetzger 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | .merlin 4 | _opam 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | env: 7 | global: 8 | - PINS="calendar:." 9 | - DISTRO="ubuntu-16.04" 10 | matrix: 11 | - PACKAGE="calendar" OCAML_VERSION="4.03" TESTS=1 EXTRA_DEPS="alcotest" 12 | - PACKAGE="calendar" OCAML_VERSION="4.04" TESTS=1 EXTRA_DEPS="alcotest" 13 | - PACKAGE="calendar" OCAML_VERSION="4.05" TESTS=1 EXTRA_DEPS="alcotest" 14 | - PACKAGE="calendar" OCAML_VERSION="4.06" TESTS=1 EXTRA_DEPS="alcotest" 15 | - PACKAGE="calendar" OCAML_VERSION="4.07" TESTS=1 EXTRA_DEPS="alcotest" 16 | - PACKAGE="calendar" OCAML_VERSION="4.08" TESTS=1 EXTRA_DEPS="alcotest" 17 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | =============================================================================== 2 | Preliminary notes: 3 | ------------------ 4 | Mark "o": new feature 5 | Mark "*": bug fixed. 6 | Mark "!": change that can break compatibility with older version of the library 7 | =============================================================================== 8 | 9 | version 3.0.0, 2022-10-11: 10 | ========================== 11 | * Fix Date.week_first_last according to ISO 8601 (@balat) 12 | * Remove incorrect time zone bound check (@vouillon) 13 | ! Switch from Str to Re (@vouillon) 14 | ! Remove date function from the version API (@c-cube) 15 | o Add some uility function for comparing dates (@loxs) 16 | * Switch the build-system to dune (@c-cube) 17 | 18 | version 2.04, 2014-10-29: 19 | =========================== 20 | * [Makefile] Fix minor issues with ocamlfind and 'make install' (from 21 | Christopher Zimmermann). 22 | o [Printer] In function from_fstring of sub-module Ftime, Fcalendar, and 23 | Precise_Fcalendar, the number of seconds corresponding to %S may be a floating 24 | point number (from Christophe Troestler' suggestion). 25 | 26 | version 2.03.2, 2012-06-26: 27 | =========================== 28 | o [Compilation] Compatibility with OCaml 4 29 | 30 | version 2.03.1, 2011-03-24: 31 | =========================== 32 | * [Calendar] Fixed bug in Calendar.prev and Fcalendar.prev: mostly raised 33 | exception Date.Out_of_bounds before. 34 | * [Printer] `Thurday' was printed instead of `Thursday' 35 | 36 | version 2.03, 2010-07-05: 37 | ========================= 38 | o [Date] new function Date.precise_sub 39 | o [Calendar] new function Calendar.precise_sub 40 | (from Dario Teixeira's suggestion) 41 | * [Compilation] detect whether native dynlink works 42 | (prevents compilation bug on Mac OS X) 43 | 44 | version 2.02, 2009-12-11: 45 | ========================= 46 | o [License] add the usual Ocaml linking exception in the license 47 | o [Calendar] Calendar_sig.Period.to_time is deprecated. 48 | Replaced by a new function Calendar_sig.Period.safe_to_time 49 | o [Date] Date.Period.nb_days is deprecated. 50 | Replaced by a new function Date.Period.safe_nb_days 51 | o [Compilation] calendarLib.cmxs provided if ocaml >= 3.11 is installed 52 | (patch of Mehdi Dogguy) 53 | o [Date] new functions Date.make_year and Date.make_year_month 54 | o [Date] improve memory representation of Date.Period.t 55 | * [Compilation] remove installation of packed *.cmi 56 | * [Compilation] bug fixed under Cygwin 57 | * [Compilation] META files was incorrect, so "ocamlfind ocamlopt" did not work 58 | * [Compilation] file date_sig.mli, time_sig.mli and calendar_sig.mli was not 59 | properly linked 60 | 61 | version 2.01.1, 2009-02-23: 62 | =========================== 63 | o [Date] add a missing coercion rule for months 64 | (e.g. "Date.make 2008 18 1" is now equal to "Date.make 2009 6 1") 65 | * [Date] bug fixed in date arithmetic operations due to the missing above 66 | feature 67 | 68 | version 2.01, 2009-01-26: 69 | ========================= 70 | o [Printer] new formats available for printers and parsers 71 | - %C century: as %Y without the two last digits 72 | - %F replace %i which is now deprecated 73 | - %P am or pm 74 | - %R shortcut for %H:%M 75 | - %s number of seconds since 1970/1/1 76 | - %z time zone in the form +hhmm (from Warren Harris' suggestion) 77 | - %:z time zone in the form +hh:mm (from Warren Harris' suggestion) 78 | - %::z time zone in the form +hh:mm:ss (from Warren Harris' suggestion) 79 | - %:::z time zone in the form +hh (from Warren Harris' suggestion) 80 | o [Printer] new paddings available for printers 81 | - 0 (zero): pad fields with zeroes like by default 82 | - ^: use uppercase if possible 83 | o [Compilation] calendarLib.cma and calendarLib.cmxa are now installed 84 | (Janne Hellsten and Guillaume Yziquel's suggestion) 85 | * [Tests] test suite now uses Utils.Float.equal if required 86 | (patch of Richard Jones) 87 | * [Compilation] small bug fixed in make install 88 | * [Compilation] support of win64 (patch of David Allsopp) 89 | 90 | version 2.0.4, 2008-07-07: 91 | ========================== 92 | o [Printer] support of "%w" and "%V" in parsers of date from string 93 | * [Printer] bug fixed with "%j" 94 | 95 | version 2.0.3, 2008-05-22: 96 | ========================== 97 | * [Compilation] module Period was not properly linked 98 | 99 | version 2.0.2, 2008-03-17: 100 | ========================== 101 | * [Compilation] Windows build problems fixed (patch of David Allsopp) 102 | 103 | version 2.0.1, 2008-02-22: 104 | ========================== 105 | * [Printer] bug fixed in printers which displayed "Mars" (instead of "March") 106 | * [Printer] bug fixed in printers when %p cannot be parsed 107 | (error message was bad) (patch of Yaron Minski) 108 | * [Compilation] bug fixed in "make install" (patch of Sean Seefried) 109 | 110 | version 2.0, 2008-02-08: 111 | ======================== 112 | o! [License] license changes from LGPLv2 to LGPLv2.1 113 | (from a suggestion of Hezekiah M. Carty) 114 | o! [Compilation] use -pack: all modules of the library are packed inside a 115 | single module CalendarLib (calendar now requires ocaml >= 3.09.1) 116 | o new modules Time_sig, Date_sig and Calendar_sig 117 | o new module Ftime (time implementation in which seconds are floats) 118 | (Hezekiah M. Carty's suggestion) 119 | o new module Calendar_builder (generic calendar implementation) 120 | o new module Fcalendar (calendar implementation using Ftime) 121 | o new module Calendar.Precise (calendar with a best precision) 122 | o hash functions are provided 123 | o [Printer] new modules Printer.Ftime and Printer.Fcalendar 124 | o [Printer] modules Printer.Date, Printer.Time and Printer.Calendar 125 | respectively replace Printer.DatePrinter, Printer.TimePrinter and 126 | Printer.CalendarPrinter. These last modules still exist but are deprecated. 127 | o [Time_Zone] new function Time_Zone.on 128 | o [Date] new function Date.from_day_of_year (Hezekiah M. Carty's suggestion) 129 | o [Date] new function Date.is_valid_date (Richard Jones' suggestion) 130 | o new module Utils 131 | o new module Version (information about version of calendar) 132 | o [Documentation] add tags @example, @raise and @see in the API documentation 133 | 134 | version 1.10, 2007-05-14: 135 | ========================= 136 | o [Printer] "from_fstring" in printers recognizes more formats. 137 | (Sean Seefried's suggestion) 138 | o [Printer] add Printer.set_word_regexp 139 | 140 | version 1.09.6, 2006-07-07: 141 | =========================== 142 | * [Date] bug fixed in Date.to_business 143 | (on some dates in the last days of january) 144 | 145 | version 1.09.5, 2006-05-26: 146 | =========================== 147 | * [Date] bug fixed in Date.nth_weekday_of_month 148 | 149 | version 1.09.4, 2006-02-13: 150 | =========================== 151 | o [Time_Zone] add Time_Zone.is_dst and Time_Zone.hour_of_dst 152 | (Daniel Peng's suggestion) 153 | * [Printer] bug fixed in printers with %I, %l, %p and %r 154 | (patch of Jerry Charumilind) 155 | * [Time_Zone] bug fixed when checking bounds in Time_Zone (patch of Daniel Peng) 156 | 157 | version 1.09.3, 2005-01-17: 158 | =========================== 159 | * [Date] bug fixed in Date.to_business 160 | 161 | version 1.09.2, 2004-12-15: 162 | =========================== 163 | * [Date] bug fixed in Date.from_unixfloat and Date.from_unixtm with 164 | time zones <> UTC 165 | 166 | version 1.09.1, 2004-11-17: 167 | =========================== 168 | o [Documentation] add tag @since in the API documentation 169 | * [Calendar] bug fixed in Calendar.to/from_unixfloat with time zones <> UTC 170 | * [Compilation] META file is now writable 171 | 172 | version 1.09.0, 2004-11-13: 173 | =========================== 174 | o [Date] add Date.to_business and Date.from_business (Richard Jone's suggestion) 175 | o [Date] add the optional parameter ?month to Date.days_in_year 176 | (Richard Jones' suggestion) 177 | o [Date] add Date.nth_weekday_of_month (Richard Jones' suggestion) 178 | o [Date] Date: add some Christian dates (Richard Jones' suggestion) 179 | o [Date] add Date.Period.ymd and Calendar.Period.ymds 180 | o [Printer] add the format string %i corresponding to the ISO-8601 notation 181 | o add "equal" in all the modules 182 | *! [Printer] ISO-8601 notation is now the default format 183 | * [Calendar.Period] bug fixed with negative period 184 | * [Calendar] bug fixed in Calendar.to/from_unixfloat and Date.to/from_unixfloat 185 | * [Date] bug fixed in Date.weeks_in_year 186 | 187 | version 1.08, 2004-05-18: 188 | ========================= 189 | o [Date] add "week_first_last" computing the first and last days of a week in a 190 | year 191 | 192 | version 1.07, 2004-03-22: 193 | ========================= 194 | o [Documentation] documentation of the API with ocamldoc 195 | * [Compilation] compile even if no ocaml native compiler is available 196 | (from a patch of Stefano Zacchiroli) 197 | 198 | version 1.06, 2003-12-05: 199 | ========================= 200 | o [Compilation] improved "make install" 201 | * [Compilation] compile with an optimized compiler (ocamlopt.opt or ocamlc.opt) 202 | if possible 203 | 204 | version 1.05, 2003-09-18: 205 | ========================= 206 | o add module Printer (from a suggestion of Stefano Zacchiroli) 207 | o! remove to_string and from_string from Date, Time and Calendar 208 | (replaced by functions of Printer) 209 | o Str library is no longer necessary 210 | o add labelled version of make in Date, Time and Calendar 211 | 212 | version 1.04, 2003-08-31: 213 | ========================= 214 | o [Period] add getters in Time.Period, Date.Period and Calendar.Period 215 | (from a suggestion of Christoph Bauer) 216 | 217 | version 1.03, 2003-08-25: 218 | ========================= 219 | o [Calendar] add "to_time" in Calendar (Julien Forest's suggestion) 220 | 221 | version 1.02, 2003-08-18: 222 | ========================= 223 | * [Compilation] bug fixed in configure.in (calendar now works with 224 | caml version > 3.06) 225 | 226 | version 1.01, 2003-07-16: 227 | ========================= 228 | o add to_unixtm, from_unixtm, to_unixfloat and from_unixfloat in 229 | Date and Calendar 230 | *! change "minut" by "minute" 231 | *! change "egal" by "equal" 232 | *! change "GMT" by "UTC" 233 | 234 | (Thank's to Eric C. Cooper for those suggestions) 235 | 236 | version 1.0, 2003-07-11: 237 | ======================== 238 | o first release 239 | -------------------------------------------------------------------------------- /CONFIGURE_HEADER: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-community/calendar/74c88deea71ede0a66f06b1bca510c191b3fd3c1/CONFIGURE_HEADER -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Calendar library 2 | Copyright (C) 2003-2009 Julien Signoles 3 | 4 | you can redistribute it and/or modify it under the terms of the GNU 5 | Lesser General Public License version 2.1 as published by the 6 | Free Software Foundation, with a special linking exception (usual 7 | for Objective Caml libraries). 8 | 9 | It is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR 12 | 13 | See the GNU Lesser General Public Licence version 2.1 for more 14 | details (enclosed in the file LGPL). 15 | 16 | The special linking exception is detailled in the enclosed file 17 | LICENSE. 18 | -------------------------------------------------------------------------------- /HEADER: -------------------------------------------------------------------------------- 1 | 2 | This file is part of Calendar. 3 | 4 | Copyright (C) 2003-2011 Julien Signoles 5 | 6 | you can redistribute it and/or modify it under the terms of the GNU 7 | Lesser General Public License version 2.1 as published by the 8 | Free Software Foundation, with a special linking exception (usual 9 | for Objective Caml libraries). 10 | 11 | It is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR 14 | 15 | See the GNU Lesser General Public Licence version 2.1 for more 16 | details (enclosed in the file LGPL). 17 | 18 | The special linking exception is detailled in the enclosed file 19 | LICENSE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: build test 3 | 4 | build: 5 | @dune build @install 6 | 7 | clean: 8 | @dune clean 9 | 10 | test: 11 | @dune runtest --no-buffer --force 12 | 13 | doc: 14 | @dune build @doc 15 | 16 | .PHONY: all clean test doc 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Calendar 2 | 3 | A calendar library for OCaml. [API documentation](https://ocaml-community.github.io/calendar/calendar/CalendarLib/index.html) 4 | 5 | [![Travis build Status](https://travis-ci.org/ocaml-community/calendar.svg?branch=3.x)](https://travis-ci.org/ocaml-community/calendar) 6 | 7 | 1. [Introduction](#1--introduction) 8 | 2. [Contents](#2--contents) 9 | 3. [Copyright](#3--copyright) 10 | 4. [Installation](#4--installation) 11 | 5. [How to use](#5--how-to-use) 12 | 6. [Documentation](#6--documentation) 13 | 7. [Makefile](#7--makefile) 14 | 8. [Contact the developers](#8--contact-the-developers) 15 | 16 | ## 1- Introduction 17 | 18 | The Calendar library provides types and operations over dates and times. 19 | This library requires OCaml 4.03.0 or higher. 20 | Older OCaml versions are unsupported. 21 | 22 | ## 2- Contents 23 | 24 | - `CHANGES` Information about the last changes 25 | - `COPYING` Information about copyright 26 | - `LGPL` Information about LGPL 27 | - `README.md` This file 28 | - `calendar_faq.txt` FAQ frow which some algorithms come 29 | - `doc` HTML documentation of the API 30 | - `src` Source files directory 31 | - `_build/default/` Directory containing the built library 32 | - `tests` Test files directory 33 | - `utils` Some utilities 34 | 35 | ## 3- Copyright 36 | 37 | This program is distributed under the GNU LGPL 2.1. 38 | See the enclosed file COPYING for more details. 39 | 40 | ## 4- Installation 41 | 42 | Easiest way is `opam install calendar`. 43 | 44 | To manually install the library, you first need to install `dune` and `re`. 45 | Then: 46 | 47 | ``` 48 | $ dune build @install 49 | $ dune install 50 | ``` 51 | 52 | You can remove files installed with : 53 | 54 | `dune uninstall` 55 | 56 | ## 5- How to use 57 | 58 | Use the `calendar` library using ocamlfind. In dune, it means having 59 | an entry `(libraries calendar)`. 60 | 61 | ## 6- Documentation 62 | 63 | The doc directory contains an html documentation of the .mli files. 64 | This documentation is available online at http://calendar.forge.ocamlcore.org/doc/ 65 | 66 | ## 7- Makefile 67 | 68 | A description of some Makefile entries follows : 69 | 70 | - `make test` will execute some tests. You'll need [alcotest](https://github.com/mirage/alcotest). 71 | 72 | To run only some tests: `dune exec ./tests/test.exe test time` (for example) 73 | 74 | - `make doc` to produce the documentation of the API. You need [odoc](https://github.com/ocaml/odoc) 75 | 76 | ## 8- Contact the developers 77 | 78 | You can report bugs at https://github.com/ocaml-community/calendar/issues 79 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | 2 | Not used anymore. 3 | See http://forge.ocamlcore.org/pm/?group_id=83 4 | -------------------------------------------------------------------------------- /calendar.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "3.0.0" 3 | author: "Julien Signoles" 4 | maintainer: "ocaml-community" 5 | license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" 6 | synopsis: "Library for handling dates and times in your program" 7 | build: [ 8 | ["dune" "build" "-p" name "-j" jobs] 9 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 10 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 11 | ] 12 | depends: [ 13 | "ocaml" {>= "4.03"} 14 | "re" {>= "1.7.2"} 15 | "dune" {>= "1.0"} 16 | "odoc" {with-doc} 17 | "alcotest" {with-test} 18 | ] 19 | tags: [ "calendar" "date" "time" "datetime" ] 20 | homepage: "https://github.com/ocaml-community/calendar" 21 | doc: "https://ocaml-community.github.io/calendar/" 22 | bug-reports: "https://github.com/ocaml-community/calendar/issues" 23 | dev-repo: "git+https://github.com/ocaml-community/calendar" 24 | description:""" 25 | Calendar is a library for handling dates and times in your program. 26 | """ 27 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name calendar) 3 | (version 3.0.0) 4 | -------------------------------------------------------------------------------- /headache_config.txt: -------------------------------------------------------------------------------- 1 | # Objective Caml source 2 | | ".*\\.mly" -> frame open:"/*" line:"*" close:"*/" 3 | | ".*\\.ml[il4]?.*" -> frame open:"(*" line:"*" close:"*)" 4 | # Misc 5 | | "configure.in" -> frame open:"#" line:"#" close:"#" 6 | | "Makefile.in" -> frame open:"#" line:"#" close:"#" 7 | -------------------------------------------------------------------------------- /man_date.txt: -------------------------------------------------------------------------------- 1 | %% a literal % 2 | 3 | %a locale's abbreviated weekday name (Sun..Sat) 4 | 5 | %A locale's full weekday name, variable length (Sun- 6 | day..Saturday) 7 | 8 | %b locale's abbreviated month name (Jan..Dec) 9 | 10 | %B locale's full month name, variable length (Jan- 11 | uary..December) 12 | 13 | %c locale's date and time (Sat Nov 04 12:02:33 EST 14 | 1989) 15 | 16 | %d day of month (01..31) 17 | 18 | %D date (mm/dd/yy) 19 | 20 | %e day of month, blank padded ( 1..31) 21 | 22 | %h same as %b 23 | 24 | %H hour (00..23) 25 | 26 | %I hour (01..12) 27 | 28 | %j day of year (001..366) 29 | 30 | %k hour ( 0..23) 31 | 32 | %l hour ( 1..12) 33 | 34 | %m month (01..12) 35 | 36 | %M minute (00..59) 37 | 38 | %n a newline 39 | 40 | %p locale's AM or PM 41 | 42 | %r time, 12-hour (hh:mm:ss [AP]M) 43 | 44 | %s seconds since `00:00:00 1970-01-01 UTC' (a GNU 45 | extension) 46 | 47 | %S second (00..60) 48 | 49 | %t a horizontal tab 50 | 51 | %T time, 24-hour (hh:mm:ss) 52 | 53 | %U week number of year with Sunday as first day of 54 | week (00..53) 55 | 56 | %V week number of year with Monday as first day of 57 | week (01..53) 58 | 59 | %w day of week (0..6); 0 represents Sunday 60 | 61 | %W week number of year with Monday as first day of 62 | week (00..53) 63 | 64 | %x locale's date representation (mm/dd/yy) 65 | 66 | %X locale's time representation (%H:%M:%S) 67 | 68 | %y last two digits of year (00..99) 69 | 70 | %Y year (1970...) 71 | 72 | %z RFC-822 style numeric timezone (-0500) (a nonstan- 73 | dard extension) 74 | 75 | %Z time zone (e.g., EDT), or nothing if no time zone 76 | is determinable 77 | 78 | By default, date pads numeric fields with zeroes. GNU 79 | date recognizes the following modifiers between `%' and a 80 | numeric directive. 81 | 82 | `-' (hyphen) do not pad the field `_' (underscore) 83 | pad the field with spaces 84 | -------------------------------------------------------------------------------- /src/calendar.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | include Calendar_builder.Make(Date)(Time) 24 | 25 | module Precise = Calendar_builder.Make_Precise(Date)(Time) 26 | -------------------------------------------------------------------------------- /src/calendar.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Calendar implementation in which seconds are integer. 24 | 25 | This module uses float. Then results may be unprecise, especially 26 | comparison of calendars which differ with few seconds. 27 | In this case, consider to use module [Precise]. *) 28 | 29 | include Calendar_sig.S with module Date = Date and module Time = Time 30 | 31 | (** More precise implementation of calendar in which seconds are integer. 32 | @since 2.0 *) 33 | module Precise: Calendar_sig.S with module Date = Date and module Time = Time 34 | -------------------------------------------------------------------------------- /src/calendar_builder.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*S Introduction. 24 | 25 | A calendar is representing by its (exact) Julian Day -. 0.5. 26 | This gap of 0.5 is because the Julian period begins 27 | January first, 4713 BC at MIDDAY (and then, this Julian day is 0.0). 28 | But, for implementation facilities, the Julian day 0.0 is coded as 29 | January first, 4713 BC at MIDNIGHT. *) 30 | 31 | module Make(D: Date_sig.S)(T: Time_sig.S) = struct 32 | 33 | (*S Datatypes. *) 34 | 35 | include Utils.Float 36 | 37 | module Date = D 38 | module Time = T 39 | 40 | type day = D.day = Sun | Mon | Tue | Wed | Thu | Fri | Sat 41 | 42 | type month = D.month = 43 | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec 44 | 45 | type year = int 46 | 47 | type second = T.second 48 | 49 | type field = [ D.field | T.field ] 50 | 51 | (*S Conversions. *) 52 | 53 | let convert x t1 t2 = x +. float (Time_Zone.gap t1 t2) /. 24. 54 | 55 | let to_gmt x = convert x (Time_Zone.current ()) Time_Zone.UTC 56 | let from_gmt x = convert x Time_Zone.UTC (Time_Zone.current ()) 57 | 58 | let from_date x = to_gmt (float (D.to_jd x)) -. 0.5 59 | 60 | (* Return the integral part of [x] as a date. *) 61 | let to_date x = D.from_jd (int_of_float (from_gmt x +. 0.5)) 62 | 63 | (* Return the fractional part of [x] as a time. *) 64 | let to_time x = 65 | let t, _ = modf (from_gmt x +. 0.5) in 66 | let i = t *. 86400. in 67 | assert (i < 86400.); 68 | T.from_seconds (T.Second.from_float i) 69 | 70 | (*S Constructors. *) 71 | 72 | let is_valid x = x >= 0. && x < 2914695. 73 | 74 | let create d t = 75 | to_gmt 76 | (float (D.to_jd d) 77 | +. T.Second.to_float (T.to_seconds t) /. 86400.) -. 0.5 78 | 79 | let make y m d h mn s = 80 | let x = create (D.make y m d) (T.make h mn s) in 81 | if is_valid x then x else raise D.Out_of_bounds 82 | 83 | let lmake ~year ?(month=1) ?(day=1) ?(hour=0) ?(minute=0) 84 | ?(second=T.Second.from_int 0) () = 85 | make year month day hour minute second 86 | 87 | let now () = 88 | let now = Unix.gettimeofday () in 89 | let gmnow = Unix.gmtime now in 90 | let frac, _ = modf now in 91 | from_gmt (make 92 | (gmnow.Unix.tm_year + 1900) 93 | (gmnow.Unix.tm_mon + 1) 94 | gmnow.Unix.tm_mday 95 | gmnow.Unix.tm_hour 96 | gmnow.Unix.tm_min 97 | (T.Second.from_float (float gmnow.Unix.tm_sec +. frac))) 98 | 99 | let from_jd x = to_gmt x 100 | let from_mjd x = to_gmt x +. 2400000.5 101 | 102 | (*S Getters. *) 103 | 104 | let to_jd x = from_gmt x 105 | let to_mjd x = from_gmt x -. 2400000.5 106 | 107 | let days_in_month x = D.days_in_month (to_date x) 108 | let day_of_week x = D.day_of_week (to_date x) 109 | let day_of_month x = D.day_of_month (to_date x) 110 | let day_of_year x = D.day_of_year (to_date x) 111 | 112 | let week x = D.week (to_date x) 113 | let month x = D.month (to_date x) 114 | let year x = D.year (to_date x) 115 | 116 | let hour x = T.hour (to_time x) 117 | let minute x = T.minute (to_time x) 118 | let second x = T.second (to_time x) 119 | 120 | (*S Coercions. *) 121 | 122 | let from_unixtm x = 123 | make 124 | (x.Unix.tm_year + 1900) (x.Unix.tm_mon + 1) x.Unix.tm_mday 125 | x.Unix.tm_hour x.Unix.tm_min (T.Second.from_int x.Unix.tm_sec) 126 | 127 | let to_unixtm x = 128 | let tm = D.to_unixtm (to_date x) 129 | and t = to_time x in 130 | { tm with 131 | Unix.tm_sec = T.Second.to_int (T.second t); 132 | Unix.tm_min = T.minute t; 133 | Unix.tm_hour = T.hour t } 134 | 135 | let jan_1_1970 = 2440587.5 136 | let from_unixfloat x = to_gmt (x /. 86400. +. jan_1_1970) 137 | let to_unixfloat x = (from_gmt x -. jan_1_1970) *. 86400. 138 | 139 | (*S Boolean operations on dates. *) 140 | 141 | let is_leap_day x = D.is_leap_day (to_date x) 142 | let is_gregorian x = D.is_gregorian (to_date x) 143 | let is_julian x = D.is_julian (to_date x) 144 | 145 | let is_pm x = T.is_pm (to_time x) 146 | let is_am x = T.is_am (to_time x) 147 | 148 | (*S Period. *) 149 | 150 | module Period = struct 151 | 152 | type +'a p = { d : 'a D.Period.period; t : 'a T.Period.period } 153 | constraint 'a = [< Period.date_field ] 154 | 155 | type +'a period = 'a p 156 | type t = Period.date_field period 157 | 158 | let split x = 159 | let rec aux s = 160 | if s < 86400. then 0, s else let d, s = aux (s -. 86400.) in d + 1, s 161 | in 162 | let s = T.Second.to_float (T.Period.length x.t) in 163 | let d, s = 164 | if s >= 0. then aux s 165 | else let d, s = aux (-. s) in - (d + 1), -. s +. 86400. 166 | in 167 | assert (s >= 0. && s < 86400.); 168 | D.Period.day d, T.Period.second (T.Second.from_float s) 169 | 170 | let normalize x = 171 | let days, seconds = split x in 172 | { d = D.Period.add x.d days; t = seconds } 173 | 174 | let empty = { d = D.Period.empty; t = T.Period.empty } 175 | 176 | let make y m d h mn s = 177 | normalize { d = D.Period.make y m d; t = T.Period.make h mn s } 178 | 179 | let lmake ?(year=0) ?(month=0) ?(day=0) ?(hour=0) ?(minute=0) 180 | ?(second=T.Second.from_int 0) () = 181 | make year month day hour minute second 182 | 183 | let year x = { empty with d = D.Period.year x } 184 | let month x = { empty with d = D.Period.month x } 185 | let week x = { empty with d = D.Period.week x } 186 | let day x = { empty with d = D.Period.day x } 187 | 188 | let hour x = normalize { empty with t = T.Period.hour x } 189 | let minute x = normalize { empty with t = T.Period.minute x } 190 | let second x = normalize { empty with t = T.Period.second x } 191 | 192 | let add x y = 193 | normalize { d = D.Period.add x.d y.d; t = T.Period.add x.t y.t } 194 | 195 | let sub x y = 196 | normalize { d = D.Period.sub x.d y.d; t = T.Period.sub x.t y.t } 197 | 198 | let opp x = normalize { d = D.Period.opp x.d; t = T.Period.opp x.t } 199 | 200 | let compare x y = 201 | let n = D.Period.compare x.d y.d in 202 | if n = 0 then T.Period.compare x.t y.t else n 203 | 204 | let equal x y = D.Period.equal x.d y.d && T.Period.equal x.t y.t 205 | 206 | let hash = Hashtbl.hash 207 | 208 | let to_date x = x.d 209 | let from_date x = { empty with d = x } 210 | let from_time x = { empty with t = x } 211 | 212 | exception Not_computable = D.Period.Not_computable 213 | 214 | let gen_to_time f x = T.Period.add (T.Period.hour (f x.d * 24)) x.t 215 | let to_time x = gen_to_time D.Period.nb_days x (* eta-expansion required *) 216 | let safe_to_time x = gen_to_time D.Period.safe_nb_days x 217 | 218 | let ymds x = 219 | let y, m, d = D.Period.ymd x.d in 220 | y, m, d, T.Period.to_seconds x.t 221 | 222 | end 223 | 224 | (*S Arithmetic operations on calendars and periods. *) 225 | 226 | let split x = 227 | let t, d = modf (from_gmt (x +. 0.5)) in 228 | let t, d = t *. 86400., int_of_float d in 229 | let t, d = if t < 0. then t +. 86400., d - 1 else t, d in 230 | assert (t >= 0. && t < 86400.); 231 | D.from_jd d, T.from_seconds (T.Second.from_float t) 232 | 233 | let unsplit d t = 234 | to_gmt 235 | (float (D.to_jd d) 236 | +. (T.Second.to_float (T.to_seconds t) /. 86400.)) -. 0.5 237 | 238 | let add x p = 239 | let d, t = split x in 240 | unsplit (D.add d (p.Period.d :> D.Period.t)) (T.add t p.Period.t) 241 | 242 | let rem x p = add x (Period.opp (p :> Period.t)) 243 | 244 | let sub x y = 245 | let d1, t1 = split x in 246 | let d2, t2 = split y in 247 | Period.normalize { Period.d = D.sub d1 d2; Period.t = T.sub t1 t2 } 248 | 249 | let precise_sub x y = 250 | let d1, t1 = split x in 251 | let d2, t2 = split y in 252 | Period.normalize { Period.d = D.precise_sub d1 d2; Period.t = T.sub t1 t2 } 253 | 254 | let next x f = 255 | let d, t = split x in 256 | match f with 257 | | #D.field as f -> unsplit (D.next d f) t 258 | | #T.field as f -> unsplit d (T.next t f) 259 | 260 | let prev x f = 261 | let d, t = split x in 262 | match f with 263 | | #D.field as f -> unsplit (D.prev d f) t 264 | | #T.field as f -> unsplit d (T.prev t f) 265 | 266 | end 267 | 268 | (* ************************************************************************* *) 269 | (* ************************************************************************* *) 270 | (* ************************************************************************* *) 271 | 272 | module Make_Precise(D: Date_sig.S)(T: Time_sig.S) = struct 273 | 274 | module Date = D 275 | module Time = T 276 | 277 | type t = { date: D.t; time: T.t } 278 | 279 | type day = D.day = Sun | Mon | Tue | Wed | Thu | Fri | Sat 280 | type month = D.month = 281 | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec 282 | 283 | type year = int 284 | 285 | type second = T.second 286 | 287 | type field = [ D.field | T.field ] 288 | 289 | (*S Comparison *) 290 | 291 | let equal x y = D.equal x.date y.date && T.equal x.time y.time 292 | 293 | let compare x y = 294 | let n = D.compare x.date y.date in 295 | if n = 0 then T.compare x.time y.time else n 296 | 297 | let hash = Hashtbl.hash 298 | 299 | (*S Conversions. *) 300 | 301 | let normalize d t = 302 | let t, days = T.normalize t in 303 | { date = D.add d (D.Period.day days); time = t } 304 | 305 | let convert x t1 t2 = 306 | let gap = T.Period.hour (Time_Zone.gap t1 t2) in 307 | normalize x.date (T.add x.time gap) 308 | 309 | let to_gmt x = convert x (Time_Zone.current ()) Time_Zone.UTC 310 | let from_gmt x = convert x Time_Zone.UTC (Time_Zone.current ()) 311 | 312 | let from_date d = to_gmt { date = d; time = T.make 0 0 (T.Second.from_int 0) } 313 | let to_date x = (from_gmt x).date 314 | let to_time x = (from_gmt x).time 315 | 316 | (*S Constructors. *) 317 | 318 | let create d t = to_gmt { date = d; time = t } 319 | 320 | let lower_bound, upper_bound = 321 | let compute () = 322 | let midday = T.midday () in 323 | let low, up = 324 | create (D.make (-4712) 1 1) midday, create (D.make 3268 1 22) midday 325 | in 326 | low, up 327 | in 328 | Time_Zone.on compute Time_Zone.UTC () 329 | 330 | let is_valid x = compare x lower_bound >= 0 && compare x upper_bound <= 0 331 | 332 | let make y m d h mn s = 333 | let x = create (D.make y m d) (T.make h mn s) in 334 | if is_valid x then x else raise D.Out_of_bounds 335 | 336 | let lmake ~year ?(month=1) ?(day=1) ?(hour=0) ?(minute=0) 337 | ?(second=T.Second.from_int 0) () = 338 | make year month day hour minute second 339 | 340 | let now () = 341 | let now = Unix.gettimeofday () in 342 | let gmnow = Unix.gmtime now in 343 | let frac, _ = modf now in 344 | from_gmt (make 345 | (gmnow.Unix.tm_year + 1900) 346 | (gmnow.Unix.tm_mon + 1) 347 | gmnow.Unix.tm_mday 348 | gmnow.Unix.tm_hour 349 | gmnow.Unix.tm_min 350 | (T.Second.from_float (float gmnow.Unix.tm_sec +. frac))) 351 | 352 | let from_jd x = 353 | let frac, intf = modf x in 354 | to_gmt 355 | { date = D.from_jd (int_of_float intf); 356 | time = T.from_seconds (T.Second.from_float (frac *. 86400. +. 43200.)) } 357 | 358 | let from_mjd x = from_jd (x +. 2400000.5) 359 | 360 | (*S Getters. *) 361 | 362 | let to_jd x = 363 | let x = from_gmt x in 364 | float (D.to_jd x.date) +. T.Second.to_float (T.to_seconds x.time) /. 86400. 365 | -. 0.5 366 | 367 | let to_mjd x = to_jd x -. 2400000.5 368 | 369 | let days_in_month x = D.days_in_month (to_date x) 370 | let day_of_week x = D.day_of_week (to_date x) 371 | let day_of_month x = D.day_of_month (to_date x) 372 | let day_of_year x = D.day_of_year (to_date x) 373 | 374 | let week x = D.week (to_date x) 375 | let month x = D.month (to_date x) 376 | let year x = D.year (to_date x) 377 | 378 | let hour x = T.hour (to_time x) 379 | let minute x = T.minute (to_time x) 380 | let second x = T.second (to_time x) 381 | 382 | (*S Coercions. *) 383 | 384 | let from_unixtm x = 385 | make 386 | (x.Unix.tm_year + 1900) (x.Unix.tm_mon + 1) x.Unix.tm_mday 387 | x.Unix.tm_hour x.Unix.tm_min (T.Second.from_int x.Unix.tm_sec) 388 | 389 | let to_unixtm x = 390 | let tm = D.to_unixtm (to_date x) 391 | and t = to_time x in 392 | { tm with 393 | Unix.tm_sec = T.Second.to_int (T.second t); 394 | Unix.tm_min = T.minute t; 395 | Unix.tm_hour = T.hour t } 396 | 397 | let jan_1_1970 = 2440587.5 398 | let from_unixfloat x = from_jd (x /. 86400. +. jan_1_1970) 399 | let to_unixfloat x = (to_jd x -. jan_1_1970) *. 86400. 400 | 401 | (*S Boolean operations on dates. *) 402 | 403 | let is_leap_day x = D.is_leap_day (to_date x) 404 | let is_gregorian x = D.is_gregorian (to_date x) 405 | let is_julian x = D.is_julian (to_date x) 406 | 407 | let is_pm x = T.is_pm (to_time x) 408 | let is_am x = T.is_am (to_time x) 409 | 410 | (*S Period. *) 411 | 412 | module Period = struct 413 | 414 | type +'a p = { d : 'a D.Period.period; t : 'a T.Period.period } 415 | constraint 'a = [< Period.date_field ] 416 | 417 | type +'a period = 'a p 418 | type t = Period.date_field period 419 | 420 | let split x = 421 | let rec aux s = 422 | if s < 86400. then 0, s else let d, s = aux (s -. 86400.) in d + 1, s 423 | in 424 | let s = T.Second.to_float (T.Period.length x.t) in 425 | let d, s = 426 | if s >= 0. then aux s 427 | else let d, s = aux (-. s) in - (d + 1), -. s +. 86400. 428 | in 429 | assert (s >= 0. && s < 86400.); 430 | D.Period.day d, T.Period.second (T.Second.from_float s) 431 | 432 | let normalize x = 433 | let days, seconds = split x in 434 | { d = D.Period.add x.d days; t = seconds } 435 | 436 | let empty = { d = D.Period.empty; t = T.Period.empty } 437 | 438 | let make y m d h mn s = 439 | normalize { d = D.Period.make y m d; t = T.Period.make h mn s } 440 | 441 | let lmake ?(year=0) ?(month=0) ?(day=0) ?(hour=0) ?(minute=0) 442 | ?(second=T.Second.from_int 0) () = 443 | make year month day hour minute second 444 | 445 | let year x = { empty with d = D.Period.year x } 446 | let month x = { empty with d = D.Period.month x } 447 | let week x = { empty with d = D.Period.week x } 448 | let day x = { empty with d = D.Period.day x } 449 | 450 | let hour x = normalize { empty with t = T.Period.hour x } 451 | let minute x = normalize { empty with t = T.Period.minute x } 452 | let second x = normalize { empty with t = T.Period.second x } 453 | 454 | let add x y = 455 | normalize { d = D.Period.add x.d y.d; t = T.Period.add x.t y.t } 456 | 457 | let sub x y = 458 | normalize { d = D.Period.sub x.d y.d; t = T.Period.sub x.t y.t } 459 | 460 | let opp x = normalize { d = D.Period.opp x.d; t = T.Period.opp x.t } 461 | 462 | let compare x y = 463 | let n = D.Period.compare x.d y.d in 464 | if n = 0 then T.Period.compare x.t y.t else n 465 | 466 | let equal x y = D.Period.equal x.d y.d && T.Period.equal x.t y.t 467 | 468 | let hash = Hashtbl.hash 469 | 470 | let to_date x = x.d 471 | let from_date x = { empty with d = x } 472 | let from_time x = { empty with t = x } 473 | 474 | exception Not_computable = D.Period.Not_computable 475 | 476 | let gen_to_time f x = T.Period.add (T.Period.hour (f x.d * 24)) x.t 477 | let to_time x = gen_to_time D.Period.nb_days x (* eta-expansion required *) 478 | let safe_to_time x = gen_to_time D.Period.safe_nb_days x 479 | 480 | let ymds x = 481 | let y, m, d = D.Period.ymd x.d in 482 | y, m, d, T.Period.to_seconds x.t 483 | 484 | end 485 | 486 | (*S Arithmetic operations on calendars and periods. *) 487 | 488 | let add x p = 489 | normalize 490 | (D.add x.date (p.Period.d :> D.Period.t)) (T.add x.time p.Period.t) 491 | 492 | let rem x p = add x (Period.opp (p :> Period.t)) 493 | 494 | let sub x y = 495 | Period.normalize 496 | { Period.d = D.sub x.date y.date; Period.t = T.sub x.time y.time } 497 | 498 | let precise_sub x y = 499 | Period.normalize 500 | { Period.d = D.precise_sub x.date y.date; 501 | Period.t = T.sub x.time y.time } 502 | 503 | let next x = function 504 | | #D.field as f -> normalize (D.next x.date f) x.time 505 | | #T.field as f -> normalize x.date (T.next x.time f) 506 | 507 | let prev x = function 508 | | #D.field as f -> normalize (D.prev x.date f) x.time 509 | | #T.field as f -> normalize x.date (T.prev x.time f) 510 | 511 | end 512 | 513 | -------------------------------------------------------------------------------- /src/calendar_builder.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Generic calendar implementation. 24 | @since 2.0 *) 25 | 26 | (** Implement a calendar from a date implementation and a time implementation. 27 | 28 | This module uses float. Then results may be very unprecise. 29 | @since 2.0 *) 30 | module Make(D:Date_sig.S)(T:Time_sig.S) 31 | : Calendar_sig.S with module Date = D and module Time = T 32 | 33 | (** Similar to {!Make} but results are more precise. The counterpart is that 34 | some operations are less efficient. 35 | @since 2.0 *) 36 | module Make_Precise(D:Date_sig.S)(T:Time_sig.S) 37 | : Calendar_sig.S with module Date = D and module Time = T 38 | -------------------------------------------------------------------------------- /src/calendar_sig.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Calendar interface. A calendar combines a date and a time: it may be seen 24 | as a 6-uple (year, month, day, hour, minute, second). 25 | 26 | If you only need operations on dates, you should better use a date 27 | implementation (like module [Date]). But if you need to manage more precise 28 | dates, use this module. The exact Julian period is now [[January, 1st 4713 29 | BC at midday GMT; January 22th, 3268 AC at midday GMT]]. *) 30 | 31 | (** Common operations for all calendar representations. 32 | @since 2.0 (this signature was before inlined in interface of Calendar). *) 33 | module type S = sig 34 | 35 | (** {2 Datatypes} *) 36 | 37 | module Date: Date_sig.S 38 | (** Date implementation used by this calendar. 39 | @since 2.0 *) 40 | 41 | module Time: Time_sig.S 42 | (** Time implementation used by this calendar. 43 | @since 2.0 *) 44 | 45 | type t 46 | 47 | type day = Date.day = Sun | Mon | Tue | Wed | Thu | Fri | Sat 48 | (** Days of the week. *) 49 | 50 | type month = Date.month = 51 | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec 52 | (** Months of the year. *) 53 | 54 | type year = Date.year 55 | (** Year as an int *) 56 | 57 | type second = Time.second 58 | 59 | type field = [ Date.field | Time.field ] 60 | (** The different fields of a calendar. *) 61 | 62 | (** {2 Constructors} *) 63 | 64 | val make : int -> int -> int -> int -> int -> second -> t 65 | (** [make year month day hour minute second] makes the calendar 66 | "year-month-day; hour-minute-second". 67 | @raise D.Out_of_bounds when a date is outside the Julian period. 68 | @raise D.Undefined when a date belongs to [[October 5th, 1582; October 69 | 14th, 1582]]. *) 70 | 71 | val lmake : 72 | year:int -> ?month:int -> ?day:int -> 73 | ?hour:int -> ?minute:int -> ?second:second -> unit -> t 74 | (** Labelled version of [make]. 75 | The default value of [month] and [day] (resp. of [hour], [minute] 76 | and [second]) is [1] (resp. [0]). 77 | @raise D.Out_of_bounds when a date is outside the Julian period. 78 | @raise D.Undefined when a date belongs to [[October 5th, 1582; October 79 | 14th, 1582]]. 80 | @since 1.05 *) 81 | 82 | val create : Date.t -> Time.t -> t 83 | (** [create d t] creates a calendar from the given date and time. *) 84 | 85 | val now : unit -> t 86 | (** [now ()] returns the current date and time (in the current time 87 | zone). *) 88 | 89 | val from_jd : float -> t 90 | (** Return the Julian day. 91 | More precise than [Date.from_jd]: the fractional part represents the 92 | time. *) 93 | 94 | val from_mjd : float -> t 95 | (** Return the Modified Julian day. 96 | It is [Julian day - 2 400 000.5] (more precise than [Date.from_mjd]). *) 97 | 98 | (** {2 Conversions} *) 99 | 100 | (** Those functions have the same behaviour as those defined in 101 | {!Time_sig.S}. *) 102 | 103 | val convert : t -> Time_Zone.t -> Time_Zone.t -> t 104 | (** @see Time_sig.S.convert *) 105 | 106 | val to_gmt : t -> t 107 | (** @see Time_sig.S.to_gmt *) 108 | 109 | val from_gmt : t -> t 110 | (** @see Time_sig.S.from_gmt *) 111 | 112 | (** {2 Getters} *) 113 | 114 | (** Those functions have the same behavious as those defined in 115 | {!Date_sig.S}. *) 116 | 117 | val days_in_month : t -> int 118 | (** @see Date_sig.S.days_in_month *) 119 | 120 | val day_of_week : t -> day 121 | (** @see Date_sig.S.days_of_week *) 122 | 123 | val day_of_month : t -> int 124 | (** @see Date_sig.S.days_of_month *) 125 | 126 | val day_of_year : t -> int 127 | (** @see Date_sig.S.days_of_year *) 128 | 129 | val week : t -> int 130 | (** @see Date_sig.S.week *) 131 | 132 | val month : t -> month 133 | (** @see Date_sig.S.month *) 134 | 135 | val year : t -> int 136 | (** @see Date_sig.S.year *) 137 | 138 | (** [to_jd] and [to_mjd] are more precise than {!Date_sig.S.to_jd} and 139 | {!Date_sig.S.to_mjd}. *) 140 | 141 | val to_jd : t -> float 142 | val to_mjd : t -> float 143 | 144 | (** Those functions have the same behavious as those defined in 145 | {!Time_sig.S}. *) 146 | 147 | val hour : t -> int 148 | (** @see Time_sig.S.hour *) 149 | 150 | val minute : t -> int 151 | (** @see Time_sig.S.minute *) 152 | 153 | val second : t -> second 154 | (** @see Time_sig.S.second *) 155 | 156 | (** {2 Calendars are comparable} *) 157 | 158 | val equal: t -> t -> bool 159 | (** Equality function between two calendars. 160 | @see Utils.Comparable.equal. *) 161 | 162 | val compare: t -> t -> int 163 | (** Comparison function between two calendars. 164 | @see Utils.Comparable.compare. *) 165 | 166 | val hash: t -> int 167 | (** Hash function for calendars. 168 | @see Utils.Comparable.hash. 169 | @since 2.0 *) 170 | 171 | (** Those functions have the same behavious as those defined in 172 | {!Date_sig.S}. *) 173 | 174 | val is_leap_day : t -> bool 175 | (** @see Date_sig.S.is_leap_day *) 176 | 177 | val is_gregorian : t -> bool 178 | (** @see Date_sig.S.is_gregorian *) 179 | 180 | val is_julian : t -> bool 181 | (** @see Date_sig.S.is_julian *) 182 | 183 | (** Those functions have the same behavious as those defined in 184 | {!Time_sig.S}. *) 185 | 186 | val is_pm : t -> bool 187 | (** @see Time_sig.S.is_pm *) 188 | 189 | val is_am : t -> bool 190 | (** @see Time_sig.S.is_am *) 191 | 192 | (** {2 Coercions} *) 193 | 194 | val to_unixtm : t -> Unix.tm 195 | (** Convert a calendar into the [unix.tm] type. 196 | The field [isdst] is always [false]. More precise than 197 | {!Date_sig.S.to_unixtm}. 198 | @since 1.01 *) 199 | 200 | val from_unixtm : Unix.tm -> t 201 | (** Inverse of [to_unixtm]. Assumes the current time zone. 202 | So, The following invariant holds: 203 | [hour (from_unixtm u) = u.Unix.tm_hour]. 204 | @since 1.01 *) 205 | 206 | val to_unixfloat : t -> float 207 | (** Convert a calendar to a float such than 208 | [to_unixfloat (make 1970 1 1 0 0 0)] returns [0.0] at UTC. 209 | So such a float is convertible with those of the module [Unix]. 210 | More precise than {!Date_sig.S.to_unixfloat}. 211 | @since 1.01 *) 212 | 213 | val from_unixfloat : float -> t 214 | (** Inverse of [to_unixfloat]. Assumes the current time zone. 215 | So, the following invariant holds: 216 | [hour (from_unixfloat u) = (Unix.gmtime u).Unix.tm_hour]. 217 | @since 1.01 *) 218 | 219 | val from_date : Date.t -> t 220 | (** Convert a date to a calendar. 221 | The time is midnight in the current time zone. *) 222 | 223 | val to_date : t -> Date.t 224 | (** Convert a calendar to a date. Time part of the calendar is ignored. *) 225 | 226 | val to_time : t -> Time.t 227 | (** Convert a calendar to a time. Date part of the calendar is ignored. 228 | @since 1.03 *) 229 | 230 | (** {2 Period} *) 231 | 232 | (** A period is the number of seconds between two calendars. *) 233 | module Period : sig 234 | 235 | (** {3 Arithmetic operations} *) 236 | 237 | type +'a period constraint 'a = [< Period.date_field ] 238 | type t = Period.date_field period 239 | (** Type of a period. *) 240 | 241 | (** {3 Period is an additive monoid} *) 242 | 243 | val empty : 'a period 244 | (** The empty period. *) 245 | 246 | val add : ([> `Day | `Week ] as 'a) period -> 'a period -> 'a period 247 | (** Addition of periods. *) 248 | 249 | val sub : ([> `Day | `Week ] as 'a) period -> 'a period -> 'a period 250 | (** Substraction of periods. *) 251 | 252 | val opp : ([> `Day | `Week ] as 'a) period -> 'a period 253 | (** Opposite of a period. *) 254 | 255 | (** {3 Periods are comparable} *) 256 | 257 | val equal: 'a period -> 'b period -> bool 258 | (** Equality function between two periods. 259 | @see Utils.Comparable.equal 260 | @since 1.09.0 *) 261 | 262 | val compare : 'a period -> 'b period -> int 263 | (** Comparison function between two periods. 264 | @see Utils.Comparable.compare *) 265 | 266 | val hash: 'a period -> int 267 | (** Hash function for periods. 268 | @see Utils.Comparable.hash 269 | @since 2.0 *) 270 | 271 | (** {3 Constructors} *) 272 | 273 | val make : int -> int -> int -> int -> int -> second -> t 274 | (** [make year month day hour minute second] makes a period of the 275 | specified length. *) 276 | 277 | val lmake : 278 | ?year:int -> ?month:int -> ?day:int -> 279 | ?hour:int -> ?minute:int -> ?second:second -> unit -> t 280 | (** Labelled version of [make]. 281 | The default value of each argument is [0]. *) 282 | 283 | (** Those functions have the same behavious as those defined in 284 | {!Date_sig.S.Period}. *) 285 | 286 | val year : int -> [> `Year ] period 287 | (** @see Date_sig.S.Period.year *) 288 | 289 | val month : int -> [> `Year | `Month ] period 290 | (** @see Date_sig.S.Period.month *) 291 | 292 | val week : int -> [> `Week | `Day ] period 293 | (** @see Date_sig.S.Period.week *) 294 | 295 | val day : int -> [> `Week | `Day ] period 296 | (** @see Date_sig.S.Period.day *) 297 | 298 | (** Those functions have the same behavious as those defined in 299 | {Time_sig.S.Period}. *) 300 | 301 | val hour : int -> [> `Week | `Day ] period 302 | (** @see Time_sig.S.Period.hour *) 303 | 304 | val minute : int -> [> `Week | `Day] period 305 | (** @see Time_sig.S.Period.minute *) 306 | 307 | val second : second -> [> `Week | `Day] period 308 | (** @see Time_sig.S.Period.second *) 309 | 310 | (** {3 Coercions} *) 311 | 312 | val from_date : 'a Date.Period.period -> 'a period 313 | (** Convert a date period to a calendar period. *) 314 | 315 | val from_time : 'a Time.Period.period -> 'a period 316 | (** Convert a time period to a calendar period. *) 317 | 318 | val to_date : 'a period -> 'a Date.Period.period 319 | (** Convert a calendar period to a date period. 320 | The fractional time period is ignored. 321 | @example [to_date (hour 60)] is equivalent to [Date.Period.days 2]. *) 322 | 323 | exception Not_computable 324 | (** [= Date.Period.Not_computable]. 325 | @since 1.04 *) 326 | 327 | val to_time : 'a period -> 'a Time.Period.period 328 | (** Convert a calendar period to a date period. 329 | @raise Not_computable if the time period is not computable. 330 | @example [to_time (day 6)] returns a time period of [24 * 3600 * 6 = 331 | 518400] seconds 332 | @example [to_time (second 30)] returns a time period of [30] seconds 333 | @example [to_time (year 1)] raises [Not_computable] because 334 | a year is not a constant number of days. 335 | @since 1.04 336 | @deprecated since 2.02: use {!safe_to_time} instead*) 337 | 338 | val safe_to_time: 339 | ([< `Week | `Day ] as 'a) period -> 'a Time.Period.period 340 | (** Equivalent to {!to_time} but never raises any exception. 341 | @since 2.02 *) 342 | 343 | val ymds: 'a period -> int * int * int * second 344 | (** Number of years, months, days and seconds in a period. 345 | @example [ymds (make 1 2 3 1 2 3)] returns [1, 2, 3, 3723] 346 | @example [ymds (make (-1) (-2) (-3) (-1) (-2) (-3)] returns 347 | [-1, -2, -4, 82677]. 348 | @since 1.09.0 *) 349 | 350 | end 351 | 352 | (** {2 Arithmetic operations on calendars and periods} *) 353 | 354 | (** Those functions have the same behavious as those defined in 355 | {!Date_sig.S}. *) 356 | 357 | val add : t -> 'a Period.period -> t 358 | (** @see Date_sig.S.add *) 359 | 360 | val sub : t -> t -> [> `Week | `Day ] Period.period 361 | (** @see Date_sig.S.sub *) 362 | 363 | val precise_sub : t -> t -> Period.t 364 | (** @see Date_sig.S.precise_sub 365 | @since 2.03 *) 366 | 367 | val rem : t -> 'a Period.period -> t 368 | (** @see Date_sig.S.rem *) 369 | 370 | val next : t -> field -> t 371 | (** @see Date_sig.S.next *) 372 | 373 | val prev : t -> field -> t 374 | (** @see Date_sig.S.prev *) 375 | 376 | end 377 | -------------------------------------------------------------------------------- /src/date.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*S Introduction. 24 | 25 | This module implements operations on dates representing by their Julian day. 26 | Most of the algorithms implemented in this module come from the FAQ 27 | available at~: 28 | \begin{center}http://www.tondering.dk/claus/calendar.html\end{center} *) 29 | 30 | (*S Datatypes. *) 31 | 32 | type field = Period.date_field 33 | 34 | (* the integer represents the Julian day *) 35 | type -'a date = int constraint 'a = [< field ] 36 | 37 | type t = field date 38 | 39 | type day = Sun | Mon | Tue | Wed | Thu | Fri | Sat 40 | 41 | type month = 42 | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec 43 | 44 | type year = int 45 | 46 | (*S Exceptions. *) 47 | 48 | exception Out_of_bounds 49 | exception Undefined 50 | 51 | (*S Locale coercions. 52 | 53 | These coercions are used in the algorithms and do not respect ISO-8601. 54 | The exported coercions are defined at the end of the module. *) 55 | 56 | (* pre: 0 <= n < 7 *) 57 | external day_of_int : int -> day = "%identity" 58 | external int_of_day : day -> int = "%identity" 59 | 60 | (* pre: 0 <= n < 12 *) 61 | external month_of_int : int -> month = "%identity" 62 | external int_of_month : month -> int = "%identity" 63 | 64 | (* Dates are comparable *) 65 | 66 | let compare = Utils.Int.compare 67 | let equal = Utils.Int.equal 68 | let ( > ) x y = compare x y = 1 69 | let ( >= ) x y = compare x y > -1 70 | let ( < ) x y = compare x y = -1 71 | let ( <= ) x y = compare x y < 1 72 | let ( ) c (ord, x, y) = 73 | if c = 0 then ord x y else c 74 | let cmp_date (y1, m1, d1) (y2, m2, d2) = 75 | compare y1 y2 (compare, m1, m2) (compare, d1, d2) 76 | 77 | 78 | let hash = Utils.Int.hash 79 | 80 | (* Constructors. *) 81 | 82 | let lt d1 d2 = (cmp_date d1 d2) < 0 83 | 84 | (* [date_ok] returns [true] is the date belongs to the Julian period; 85 | [false] otherwise. *) 86 | let date_ok y m d = lt (-4713, 12, 31) (y, m, d) && lt (y, m, d) (3268, 1, 23) 87 | 88 | (* Coerce month to the interval ]-oo; 12]. 89 | Note that the used algorithm of [make] does not require any coercion for 90 | negative months *) 91 | let coerce_month y m = 92 | if m < 0 then 93 | y, m 94 | (* (* the below commented lines coerce [m] inside the interval [1;12] 95 | instead of ]-oo;12]*) 96 | let diff_y = (m + 1) / 12 - 1 in 97 | y + diff_y, - 12 * diff_y + m*) 98 | else 99 | let pred_m = pred m in 100 | y + pred_m / 12, pred_m mod 12 + 1 101 | 102 | let make y m d = 103 | let y, m = coerce_month y m in 104 | if date_ok y m d then 105 | let a = (14 - m) / 12 in 106 | let y' = y + 4800 - a in 107 | let m' = m + 12 * a - 3 in 108 | if lt (1582, 10, 14) (y, m, d) then 109 | (* Gregorian calendar *) 110 | d + (153 * m' + 2) / 5 + y' * 365 + y' / 4 - y' / 100 + y' / 400 - 32045 111 | else if lt (y, m, d) (1582, 10, 5) then 112 | (* Julian calendar *) 113 | d + (153 * m' + 2) / 5 + y' * 365 + y' / 4 - 32083 114 | else 115 | raise Undefined 116 | else 117 | raise Out_of_bounds 118 | 119 | let lmake ~year ?(month = 1) ?(day = 1) () = make year month day 120 | 121 | let make_year y = make y 1 1 122 | let make_year_month y m = make y m 1 123 | 124 | let current_day day gmt_hour = 125 | let hour = Time_Zone.from_gmt () + gmt_hour in 126 | (* change the day according to the time zone *) 127 | if hour < 0 then begin 128 | assert (hour > - 13); 129 | day - 1 130 | end else if hour >= 24 then begin 131 | assert (hour < 36); 132 | day + 1 133 | end else 134 | day 135 | 136 | let jan_1_1970 = 2440588 137 | 138 | let from_unixfloat x = 139 | let d = int_of_float (x /. 86400.) + jan_1_1970 in 140 | current_day d (Unix.gmtime x).Unix.tm_hour 141 | 142 | let from_day_of_year y d = make y 1 d 143 | 144 | let today () = from_unixfloat (Unix.time ()) 145 | 146 | let from_jd n = n 147 | let to_jd d = d 148 | 149 | let from_mjd x = x + 2400001 150 | let to_mjd d = d - 2400001 151 | 152 | (*S Useful operations. *) 153 | 154 | let is_leap_year y = 155 | if y > 1582 then (* Gregorian calendar *) 156 | y mod 4 = 0 && (y mod 100 <> 0 || y mod 400 = 0) 157 | else (* Julian calendar *) 158 | if y > (- 45) && y <= (- 8) then 159 | (* every year divisible by 3 is a leap year between 45 BC and 9 BC *) 160 | y mod 3 = 0 161 | else if y <= (- 45) || y >= 8 then y mod 4 = 0 162 | else (* no leap year between 8 BC and 7 AD *) false 163 | 164 | (*S Boolean operations on dates. *) 165 | 166 | let is_julian d = d < 2299161 167 | let is_gregorian d = d >= 2299161 168 | 169 | (*S Getters. *) 170 | 171 | (* [a] and [e] are auxiliary functions for [day_of_month], [month] 172 | and [year]. *) 173 | let a d = d + 32044 174 | 175 | let e d = 176 | let c = 177 | if is_julian d then d + 32082 178 | else let a = a d in a - (((4 * a + 3) / 146097) * 146097) / 4 179 | in c - (1461 * ((4 * c + 3) / 1461)) / 4 180 | 181 | let day_of_month d = 182 | let e = e d in 183 | let m = (5 * e + 2) / 153 in 184 | e - (153 * m + 2) / 5 + 1 185 | 186 | let int_month d = let m = (5 * e d + 2) / 153 in m + 3 - 12 * (m / 10) 187 | 188 | let month d = month_of_int (int_month d - 1) 189 | 190 | let year d = 191 | let b, c = 192 | if is_julian d then 0, d + 32082 193 | else 194 | let a = a d in 195 | let b = (4 * a + 3) / 146097 in 196 | b, a - (b * 146097) / 4 in 197 | let d = (4 * c + 3) / 1461 in 198 | let e = c - (1461 * d) / 4 in 199 | b * 100 + d - 4800 + ((5 * e + 2) / 153) / 10 200 | 201 | let int_day_of_week d = (d + 1) mod 7 202 | 203 | let day_of_week d = day_of_int (int_day_of_week d) 204 | 205 | let day_of_year d = d - make (year d - 1) 12 31 206 | 207 | (* [week] implements an algorithm coming from Stefan Potthast. *) 208 | let week d = 209 | let d4 = (d + 31741 - (d mod 7)) mod 146097 mod 36524 mod 1461 in 210 | let l = d4 / 1460 in 211 | (((d4 - l) mod 365) + l) / 7 + 1 212 | 213 | let days_in_month d = 214 | match month d with 215 | | Jan | Mar | May | Jul | Aug | Oct | Dec -> 31 216 | | Apr | Jun | Sep | Nov -> 30 217 | | Feb -> if is_leap_year (year d) then 29 else 28 218 | 219 | (* Boolean operation using some getters. *) 220 | let is_leap_day d = 221 | is_leap_year (year d) && month d = Feb && day_of_month d = 24 222 | 223 | let is_valid_date y m d = 224 | try 225 | let t = make y m d in 226 | year t = y && int_month t = m && day_of_month t = d 227 | with Out_of_bounds | Undefined -> 228 | false 229 | 230 | (*S Period. *) 231 | 232 | module Period = struct 233 | 234 | (* Cannot use an [int] : periods on months and years have not a constant 235 | number of days. 236 | For example, if we add a "one year" period [p] to the date 2000-3-12, 237 | [p] corresponds to 366 days (because 2000 is a leap year) and the 238 | resulting date is 2001-3-12 (yep, one year later). But if we add [p] to 239 | the date 1999-3-12, [p] corresponds to 365 days and the resulting date is 240 | 2000-3-12 (yep, one year later too). *) 241 | type +'a period = { m (* month *) : int; d (* day *) : int } 242 | constraint 'a = [< field ] 243 | 244 | type +'a p = 'a period 245 | type t = field period 246 | 247 | let empty = { m = 0; d = 0 } 248 | 249 | let make y m d = { m = 12 * y + m; d = d } 250 | let lmake ?(year = 0) ?(month = 0) ?(day = 0) () = make year month day 251 | 252 | let day n = { empty with d = n } 253 | let week n = { empty with d = 7 * n } 254 | let month n = { empty with m = n } 255 | let year n = { empty with m = 12 * n } 256 | 257 | let add x y = { m = x.m + y.m; d = x.d + y.d } 258 | let sub x y = { m = x.m - y.m; d = x.d - y.d } 259 | let opp x = { m = - x.m; d = - x.d } 260 | 261 | (* exactly equivalent to [Pervasives.compare] but more flexible typing *) 262 | let compare x y = 263 | let n = compare x.m y.m in 264 | if n = 0 then compare x.d y.d else n 265 | let equal x y = compare x y = 0 266 | let hash = Hashtbl.hash 267 | 268 | exception Not_computable 269 | 270 | let nb_days p = if p.m <> 0 then raise Not_computable else p.d 271 | 272 | let safe_nb_days p = p.d 273 | 274 | let ymd p = p.m / 12, p.m mod 12, p.d 275 | 276 | end 277 | 278 | (*S Arithmetic operations on dates and periods. *) 279 | 280 | let add d p = 281 | let y,m,day = Period.ymd p in 282 | make 283 | (year d + y) 284 | (int_month d + m) 285 | (day_of_month d + day) 286 | 287 | let sub x y = { Period.empty with Period.d = x - y } 288 | 289 | let precise_sub y x = 290 | let rec aux m = 291 | if x + 31 * m < y then 292 | aux (m + 1) 293 | else 294 | let y' = add x (Period.month m) in 295 | let d = y - y' in 296 | if d < 0 then 297 | let m = m - 1 in 298 | (* don't use [y'] below: [m] changes *) 299 | m, d + days_in_month (add x (Period.month m)) 300 | else if d >= days_in_month y' then 301 | aux (m + 1) 302 | else 303 | m, d 304 | in 305 | let m, d = aux ((y - x) / 31) in 306 | { Period.m = m; d = d } 307 | 308 | let rem d p = add d (Period.opp p) 309 | 310 | let next d = function 311 | | `Year -> add d (Period.year 1) 312 | | `Month -> add d (Period.month 1) 313 | | `Week -> add d (Period.day 7) 314 | | `Day -> add d (Period.day 1) 315 | 316 | let prev d = function 317 | | `Year -> add d (Period.year (- 1)) 318 | | `Month -> add d (Period.month (- 1)) 319 | | `Week -> add d (Period.day (- 7)) 320 | | `Day -> add d (Period.day (- 1)) 321 | 322 | (*S Operations on years. *) 323 | 324 | let same_calendar y1 y2 = 325 | let d = y1 - y2 in 326 | let aux = 327 | if is_leap_year y1 then true 328 | else if is_leap_year (y1 - 1) then d mod 6 = 0 || d mod 17 = 0 329 | else if is_leap_year (y1 - 2) then d mod 11 = 0 || d mod 17 = 0 330 | else if is_leap_year (y1 - 3) then d mod 11 = 0 331 | else false 332 | in d mod 28 = 0 || aux 333 | 334 | let days_in_year = 335 | let days = [| 31; 59; 90; 120; 151; 181; 212; 243; 273; 304; 334; 365 |] in 336 | fun ?(month=Dec) y -> 337 | let m = int_of_month month in 338 | let res = days.(m) in 339 | if is_leap_year y && m > 0 then res + 1 else res 340 | 341 | let weeks_in_year y = 342 | let first_day = day_of_week (make y 1 1) in 343 | match first_day with 344 | | Thu -> 53 345 | | Wed -> if is_leap_year y then 53 else 52 346 | | _ -> 52 347 | 348 | let week_first_last w y = 349 | let d = make y 1 4 in (* January 4th must be in the first week (ISO 8601) *) 350 | let d = d - d mod 7 in 351 | let b = d + 7 * (w - 1) in 352 | b, 6 + b 353 | 354 | let nth_weekday_of_month y m d n = 355 | let first = make y (int_of_month m + 1) 1 in 356 | let gap = 357 | let diff = int_of_day d - int_day_of_week first in 358 | if diff >= 0 then diff - 7 else diff 359 | in 360 | first + 7 * n + gap 361 | 362 | let century y = if y mod 100 = 0 then y / 100 else y / 100 + 1 363 | 364 | let millenium y = if y mod 1000 = 0 then y / 1000 else y / 1000 + 1 365 | 366 | let solar_number y = (y + 8) mod 28 + 1 367 | 368 | let indiction y = (y + 2) mod 15 + 1 369 | 370 | let golden_number y = y mod 19 + 1 371 | 372 | let epact y = 373 | let julian_epact = (11 * (golden_number y - 1)) mod 30 in 374 | if y <= 1582 then julian_epact (* Julian calendar *) 375 | else (* Gregorian calendar *) 376 | let c = y / 100 + 1 (* century *) in 377 | (* 1900 belongs to the 20th century for this algorithm *) 378 | abs ((julian_epact - (3 * c) / 4 + (8 * c + 5) / 25 + 8) mod 30) 379 | 380 | (* [easter] implements the algorithm of Oudin (1940) *) 381 | let easter y = 382 | let g = y mod 19 in 383 | let i, j = 384 | if y <= 1582 then (* Julian calendar *) 385 | let i = (19 * g + 15) mod 30 in 386 | i, (y + y / 4 + i) mod 7 387 | else (* Gregorian calendar *) 388 | let c = y / 100 in 389 | let h = (c - c / 4 - (8 * c + 13) / 25 + 19 * g + 15) mod 30 in 390 | let i = h - (h / 28) * (1 - (h / 28) * (29 / (h + 1)) * ((21 - g) / 11)) 391 | in i, (y + y / 4 + i + 2 - c + c / 4) mod 7 392 | in 393 | let l = i - j in 394 | let m = 3 + (l + 40) / 44 in 395 | make y m (l + 28 - 31 * (m / 4)) 396 | 397 | let carnaval y = easter y - 48 398 | let mardi_gras y = easter y - 47 399 | let ash y = easter y - 46 400 | let palm y = easter y - 7 401 | let easter_friday y = easter y - 2 402 | let easter_saturday y = easter y - 1 403 | let easter_monday y = easter y + 1 404 | let ascension y = easter y + 39 405 | let withsunday y = easter y + 49 406 | let withmonday y = easter y + 50 407 | let corpus_christi y = easter y + 60 408 | 409 | (*S Exported Coercions. *) 410 | 411 | let from_unixtm x = 412 | let d = (* current day at GMT *) 413 | make (x.Unix.tm_year + 1900) (x.Unix.tm_mon + 1) x.Unix.tm_mday 414 | in 415 | current_day d x.Unix.tm_hour 416 | 417 | let to_unixtm d = 418 | { Unix.tm_sec = 0; Unix.tm_min = 0; Unix.tm_hour = 0; 419 | Unix.tm_mday = day_of_month d; 420 | Unix.tm_mon = int_month d - 1; 421 | Unix.tm_year = year d - 1900; 422 | Unix.tm_wday = int_day_of_week d; 423 | Unix.tm_yday = day_of_year d - 1; 424 | Unix.tm_isdst = false } 425 | 426 | let to_unixfloat x = float_of_int (x - jan_1_1970) *. 86400. 427 | (* do not replace [*.] by [*]: the result is bigger than [max_int] ! *) 428 | 429 | let to_business d = 430 | let w = week d in 431 | let y = 432 | let y = year d in 433 | match int_month d with 434 | | 1 -> let x = y - 1 in if w = weeks_in_year x then x else y 435 | | 12 -> if w = 1 then y + 1 else y 436 | | _ -> y 437 | in 438 | y, w, day_of_week d 439 | 440 | let int_of_day d = let n = int_of_day d in if n = 0 then 7 else n 441 | (* Used by [from_business] *) 442 | 443 | let from_business y w d = 444 | if w < 1 || w > weeks_in_year y then invalid_arg "from_business: bad week"; 445 | let first = 446 | try make y 1 1 447 | with Out_of_bounds | Undefined -> invalid_arg "from_business: bad date" 448 | in 449 | let first_day = int_day_of_week first in 450 | let w = if first_day > 4 then w else w - 1 in 451 | first + w * 7 + int_of_day d - first_day 452 | 453 | (* These coercions redefine those defined at the beginning of the module. 454 | They respect ISO-8601. *) 455 | 456 | let int_of_day = int_of_day 457 | 458 | let day_of_int n = 459 | if n > 0 && n < 7 then day_of_int n 460 | else if n = 7 then day_of_int 0 461 | else invalid_arg "Not a day" 462 | 463 | let int_of_month m = int_of_month m + 1 464 | 465 | let month_of_int n = 466 | if n > 0 && n < 13 then month_of_int (n - 1) else invalid_arg "Not a month" 467 | -------------------------------------------------------------------------------- /src/date.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Date implementation. *) 24 | 25 | include Date_sig.S 26 | -------------------------------------------------------------------------------- /src/date_sig.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Date interface. A date may be seen as a triple (year, month, day). 24 | 25 | All the dates should belong to 26 | [[January, 1st 4713 BC; January 22th, 3268 AC]] (called the Julian period). 27 | An [Out_of_bounds] exception is raised if you attempt to create a date 28 | outside the Julian period. 29 | 30 | If a date [d] does not exists and if [d_bef] (resp. [d_aft]) is 31 | the last (resp. first) existing date before (resp. after) [d], 32 | [d] is automatically coerced to [d_aft + d - d_bef - 1]. 33 | For example, both dates "February 29th, 2003" and 34 | "February 30th, 2003" do not exist and they are coerced respectively to the 35 | date "Mars 1st, 2003" and "Mars 2nd, 2003". 36 | This rule is called the coercion rule. 37 | As an exception to the coercion rule, the date belonging to 38 | [[October 5th, 1582; October 14th, 1582]] do not exist and an [Undefined] 39 | exception is raised if you attempt to create such a date. 40 | Those dropped days correspond to the change from the Julian to the Gregorian 41 | calendar. *) 42 | 43 | (** Common operations for all date representations. 44 | @since 2.0 (this signature was before inlined in interface of Date). *) 45 | module type S = sig 46 | 47 | (** {2 Datatypes} *) 48 | 49 | (** The different fields of a date. 50 | @since 2.02 *) 51 | type field = Period.date_field 52 | 53 | (** Type of a date, without specifying any precision level. 54 | @since 2.02 *) 55 | type -'a date constraint 'a = [< field ] 56 | 57 | (** Type of a date. *) 58 | type t = field date 59 | 60 | (** Days of the week. *) 61 | type day = Sun | Mon | Tue | Wed | Thu | Fri | Sat 62 | 63 | (** Months of the year. *) 64 | type month = 65 | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec 66 | 67 | (** Year as an [int]. *) 68 | type year = int 69 | 70 | (** {2 Exceptions} *) 71 | 72 | exception Out_of_bounds 73 | (** Raised when a date is outside the Julian period. *) 74 | 75 | exception Undefined 76 | (** Raised when a date belongs to 77 | [[October 5th, 1582; October 14th, 1582]]. *) 78 | 79 | (** {2 Constructors} *) 80 | 81 | val make : year -> int -> int -> t 82 | (** [make year month day] makes the date year-month-day. A BC year [y] 83 | corresponds to the year [-(y+1)]. 84 | @example years (5 BC) and (1 BC) respectively correspond to years 85 | (-4) and 0. 86 | @raise Out_of_bounds when a date is outside the Julian period. 87 | @raise Undefined when a date belongs to [[October 5th, 1582; October 88 | 14th, 1582]]. *) 89 | 90 | val lmake : year:year -> ?month:int -> ?day:int -> unit -> t 91 | (** Labelled version of [make]. 92 | The default value of [month] and [day] is [1]. 93 | @raise Out_of_bounds when a date is outside the Julian period. 94 | @raise Undefined when a date belongs to [[October 5th, 1582; October 95 | 14th, 1582]]. 96 | @since 1.05 *) 97 | 98 | val make_year: int -> [< `Year ] date 99 | (** [make_year y] makes a date only represented by its year [y]. The month 100 | and the day of such a date are not relevant. 101 | @since 2.02 *) 102 | 103 | val make_year_month: int -> int -> [< `Year | `Month ] date 104 | (** [make_year_month y m] makes a date only represented by its year [y] and 105 | its month [m]. The day of such a date is not relevant. 106 | @since 2.02 *) 107 | 108 | val today : unit -> t 109 | (** Date of the current day (based on [Time_Zone.current ()]). *) 110 | 111 | val from_jd : int -> t 112 | (** Make a date from its Julian day. 113 | @example [from_jd 0] returns the date 4713 BC-1-1. *) 114 | 115 | val from_mjd : int -> t 116 | (** Make a date from its modified Julian day (i.e. Julian day - 2 400 001). 117 | The Modified Julian day is more manageable than the Julian day. 118 | @example [from_mjd 0] returns the date 1858-11-17. *) 119 | 120 | val from_day_of_year: year -> int -> t 121 | (** Make a date from a year and its day of the year. 122 | @example [from_day_of_year 2008 39] returns the date 2008-2-8. 123 | @since 2.0 *) 124 | 125 | (** {2 Getters} *) 126 | 127 | val days_in_month : [> `Year | `Month ] date -> int 128 | (** Number of days in the month of a date. 129 | @example [days_in_month (make 2003 6 26)] returns [30]. *) 130 | 131 | val day_of_week : t -> day 132 | (** Day of the week. 133 | @example [day_of_week (make 2003 6 26)] returns [Thu]. *) 134 | 135 | val day_of_month : t -> int 136 | (** Day of the month. 137 | @example [day_of_month (make 2003 6 26)] returns [26]. *) 138 | 139 | val day_of_year : t -> int 140 | (** Day of the year. 141 | @example [day_of_year (make 2003 1 5)] returns [5] 142 | @example [day_of_year (make 2003 12 28)] returns [362]. *) 143 | 144 | val week : t -> int 145 | (** Week. 146 | @example [week (make 2000 1 3)] returns [1]. 147 | @example [week (make 2000 1 2)] returns [52]. 148 | @example [week (make 2003 12 28)] returns [52]. 149 | @example [week (make 2003 12 29)] returns [1]. *) 150 | 151 | val month : [> `Month ] date -> month 152 | (** Month. 153 | @example [month (make 2003 6 26)] returns [Jun]. *) 154 | 155 | val year : [> `Year ] date -> year 156 | (** Year. 157 | @example [year (make 2003 6 26)] returns [2003]. *) 158 | 159 | val to_jd : t -> int 160 | (** Julian day. 161 | @example [to_jd (make (-4712) 1 1)] returns 0. *) 162 | 163 | val to_mjd : t -> int 164 | (** Modified Julian day (i.e. Julian day - 2 400 001). 165 | The Modified Julian day is more manageable than the Julian day. 166 | @example [to_mjd (make 1858 11 17)] returns 0. *) 167 | 168 | (** {2 Dates are comparable} *) 169 | 170 | val equal: 'a date -> 'b date -> bool 171 | (** Equality function between two dates. 172 | @see Utils.Comparable.equal 173 | @since 1.09.0 *) 174 | 175 | val compare : 'a date -> 'b date -> int 176 | (** Comparison function between two dates. 177 | @see Utils.Comparable.compare *) 178 | 179 | val ( > ) : 'a date -> 'b date -> bool 180 | (** Check if the first date is later than the second *) 181 | 182 | val ( >= ) : 'a date -> 'b date -> bool 183 | (** Check if the first date is later or equal to the second *) 184 | 185 | val ( < ) : 'a date -> 'b date -> bool 186 | (** Check if the first date is earlier than the second *) 187 | 188 | val ( <= ) : 'a date -> 'b date -> bool 189 | (** Check if the first date is earlier or equal to the second *) 190 | 191 | val hash: 'a date -> int 192 | (** Hash function for dates. 193 | @see Utils.Comparable.hash 194 | @since 2.0 *) 195 | 196 | (** {2 Boolean operations on dates} *) 197 | 198 | val is_valid_date: year -> int -> int -> bool 199 | (** Check if a date is valid, that is the date has not been coerced to look 200 | like a real date. 201 | @example [is_valid_date 2008 2 8] returns [true] 202 | @example [is_valid_date 2008 2 30] returns [false] 203 | @since 2.0 *) 204 | 205 | val is_leap_day : t -> bool 206 | (** Return [true] if a date is a leap day 207 | (i.e. February, 24th of a leap year); [false] otherwise. *) 208 | 209 | val is_gregorian : t -> bool 210 | (** Return [true] if a date belongs to the Gregorian calendar; 211 | [false] otherwise. *) 212 | 213 | val is_julian : t -> bool 214 | (** Return [true] iff a date belongs to the Julian calendar; 215 | [false] otherwise. *) 216 | 217 | (** {2 Coercions} *) 218 | 219 | val to_unixtm : t -> Unix.tm 220 | (** Convert a date into the [Unix.tm] type. 221 | The field [is_isdst] is always [false]. The fields [Unix.tm_sec], 222 | [Unix.tm_min] and [Unix.tm_hour] are irrelevant. 223 | @since 1.01 *) 224 | 225 | val from_unixtm : Unix.tm -> t 226 | (** Inverse of [to_unixtm]. Assume the current time zone. 227 | @since 1.01 *) 228 | 229 | val to_unixfloat : t -> float 230 | (** Convert a date to a float such than [to_unixfloat (make 1970 1 1)] 231 | returns [0.0]. So such a float is convertible with those of the [Unix] 232 | module. The fractional part of the result is always [0]. 233 | @since 1.01 *) 234 | 235 | val from_unixfloat : float -> t 236 | (** Inverse of [to_unixfloat]. Ignore the fractional part of the argument. 237 | Assume the current time zone. 238 | @since 1.01 *) 239 | 240 | val to_business: t -> year * int * day 241 | (** Return the "business week" and the day in this week respecting ISO 8601. 242 | Notice that business weeks at the beginning and end of the year can 243 | sometimes have year numbers which don't match the real year. 244 | @example [to_business (make 2000 1 3)] returns [2000, 1, Mon] 245 | @example [to_business (make 2000 1 2)] returns [1999, 52, Sun] 246 | @example [to_business (make 2003 12 28)] returns [2003, 52, Sun] 247 | @example [to_business (make 2003 12 29)] returns [2004, 1, Mon]. 248 | @since 1.09.0 *) 249 | 250 | val from_business: year -> int -> day -> t 251 | (** Inverse of [to_business] respecting ISO-8601. 252 | Notice that business weeks at the beginning and end of the year 253 | can sometimes have year numbers which don't match the real year. 254 | @raise Invalid_argument if the date is bad. 255 | @since 1.09.0 *) 256 | 257 | val int_of_day : day -> int 258 | (** Convert a day to an integer respecting ISO-8601. 259 | So, Monday is 1, Tuesday is 2, ..., and sunday is 7. *) 260 | 261 | val day_of_int : int -> day 262 | (** Inverse of [int_of_day]. 263 | @raise Invalid_argument if the argument does not belong to [1; 7]. *) 264 | 265 | val int_of_month : month -> int 266 | (** Convert a month to an integer respecting ISO-8601. 267 | So, January is 1, February is 2 and so on. *) 268 | 269 | val month_of_int : int -> month 270 | (** Inverse of [int_of_month]. 271 | @raise Invalid_argument if the argument does not belong to [1; 12]. *) 272 | 273 | (** {2 Period} *) 274 | 275 | (** A period is the number of days between two dates. *) 276 | module Period : sig 277 | 278 | (** {3 Arithmetic operations} *) 279 | 280 | type +'a p constraint 'a = [< field ] 281 | include Period.S with type +'a period = 'a p 282 | 283 | (** {3 Constructors} *) 284 | 285 | val make: int -> int -> int -> t 286 | (** [make year month day] makes a period of the specified length. *) 287 | 288 | val lmake: ?year:int -> ?month:int -> ?day:int -> unit -> t 289 | (** Labelled version of [make]. 290 | The default value of each argument is [0]. *) 291 | 292 | val year: int -> [> `Year ] period 293 | (** [year n] makes a period of [n] years. *) 294 | 295 | val month: int -> [> `Year | `Month ] period 296 | (** [month n] makes a period of [n] months. *) 297 | 298 | val week: int -> [> `Week | `Day ] period 299 | (** [week n] makes a period of [n] weeks. *) 300 | 301 | val day: int -> [> `Week | `Day ] period 302 | (** [day n] makes a period of [n] days. *) 303 | 304 | (** {3 Getters} *) 305 | 306 | exception Not_computable 307 | (** @since 1.04 *) 308 | 309 | val nb_days: 'a period -> int 310 | (** Number of days in a period. 311 | @raise Not_computable if the number of days is not computable. 312 | @example [nb_days (day 6)] returns [6] 313 | @example [nb_days (year 1)] raises [Not_computable] because a year is 314 | not a constant number of days. 315 | @since 1.04 316 | @deprecated since 2.02: use {!safe_nb_days} instead *) 317 | 318 | val safe_nb_days: [< `Week | `Day ] period -> int 319 | (** Equivalent to {!nb_days} but never raises any exception. 320 | @since 2.02 *) 321 | 322 | val ymd: 'a period -> int * int * int 323 | (** Number of years, months and days in a period. 324 | @example [ymd (make 1 2 3)] returns [1, 2, 3]. 325 | @since 1.09.0 *) 326 | 327 | end 328 | 329 | (** {2 Arithmetic operations on dates and periods} *) 330 | 331 | val add : 'a date -> 'a Period.period -> 'a date 332 | (** [add d p] returns [d + p]. 333 | @raise Out_of_bounds when the resulting date is outside the Julian 334 | period. 335 | @raise Undefined when the resulting date belongs to [[October 5th, 336 | 1582; October 14th, 1582]]. 337 | @example [add (make 2003 12 31) (Period.month 1)] returns the date 338 | 2004-1-31 339 | @example [add (make 2003 12 31) (Period.month 2)] returns the date 340 | 2004-3-2 (following the coercion rule describes in the introduction). *) 341 | 342 | val sub : 'a date -> 'a date -> [> `Week | `Day ] Period.period 343 | (** [sub d1 d2] returns the period between [d1] and [d2]. *) 344 | 345 | val precise_sub : 'a date -> 'a date -> Period.t 346 | (** [precise_sub d1 d2] returns the period between [d1] and [d2]. 347 | It is equivalent to [sub], but: 348 | - the period is expressed with a number of years, months and days, not 349 | only with a number of days; 350 | - it is less efficient. 351 | @since 2.03 *) 352 | 353 | val rem : 'a date -> 'a Period.period -> 'a date 354 | (** [rem d p] is equivalent to [add d (Period.opp p)]. 355 | @raise Out_of_bounds when the resulting date is outside the Julian 356 | period. 357 | @raise Undefined when the resulting date belongs to [[October 5th, 358 | 1582; October 14th, 1582]]. *) 359 | 360 | val next : 'a date -> ([< field ] as 'a) -> 'a date 361 | (** [next d f] returns the date corresponding to the next specified field. 362 | @raise Out_of_bounds when the resulting date is outside the Julian 363 | period. 364 | @raise Undefined when the resulting date belongs to [[October 5th, 365 | 1582; October 14th, 1582]]. 366 | @example [next (make 2003 12 31) `Month] returns the date 2004-1-31 367 | (i.e. one month later). *) 368 | 369 | val prev : 'a date -> ([< field ] as 'a) -> 'a date 370 | (** [prev d f] returns the date corresponding to the previous specified 371 | field. 372 | @raise Out_of_bounds when the resulting date is outside the Julian 373 | period. 374 | @raise Undefined when the resulting date belongs to [[October 5th, 375 | 1582; October 14th, 1582]]. 376 | @example [prev (make 2003 12 31) `Year] returns the date 2002-12-31 377 | (i.e. one year ago). *) 378 | 379 | (** {2 Operations on years} *) 380 | 381 | val is_leap_year : year -> bool 382 | (** Return [true] if a year is a leap year; [false] otherwise. *) 383 | 384 | val same_calendar : year -> year -> bool 385 | (** Return [true] if two years have the same calendar; [false] 386 | otherwise. *) 387 | 388 | val days_in_year : ?month:month -> year -> int 389 | (** Number of days in a year. 390 | 391 | [days_in_year ~month y] returns the number of days in the year [y] up 392 | to the end of the given month. Thus [days_in_year ~month:Dec y] is the 393 | same as [days_in_year y]. *) 394 | 395 | val weeks_in_year: year -> int 396 | (** Number of weeks in a year. *) 397 | 398 | val week_first_last: int -> year -> t * t 399 | (** Return the first and last days of a week in a year. 400 | @since 1.08 *) 401 | 402 | val nth_weekday_of_month: year -> month -> day -> int -> t 403 | (** [nth_weekday_of_month y m d n] returns the [n]-th day [d] in the month 404 | [m] of the year [y] (for instance the 3rd Thursday of the month). 405 | @since 1.09.0 *) 406 | 407 | val century : year -> int 408 | (** Century of a year. 409 | @example [century 2000] returns 20 410 | @example [century 2001] returns 21. *) 411 | 412 | val millenium : year -> int 413 | (** Millenium of a year. 414 | @example [millenium 2000] returns 2 415 | @example [millenium 2001] returns 3. *) 416 | 417 | val solar_number : year -> int 418 | (** Solar number. 419 | 420 | In the Julian calendar there is a one-to-one relationship between the 421 | Solar number and the day on which a particular date falls. *) 422 | 423 | val indiction : year -> int 424 | (** Indiction. 425 | 426 | The Indiction was used in the middle ages to specify the position of a 427 | year in a 15 year taxation cycle. It was introduced by emperor 428 | Constantine the Great on 1 September 312 and ceased to be used in 429 | 1806. 430 | 431 | The Indiction has no astronomical significance. *) 432 | 433 | val golden_number : year -> int 434 | (** Golden number. 435 | 436 | Considering that the relationship between the moon's phases and the 437 | days of the year repeats itself every 19 years, it is natural to 438 | associate a number between 1 and 19 with each year. 439 | This number is the so-called Golden number. *) 440 | 441 | val epact : year -> int 442 | (** Epact. 443 | 444 | The Epact is a measure of the age of the moon (i.e. the number of days 445 | that have passed since an "official" new moon) on a particular date. *) 446 | 447 | val easter : year -> t 448 | (** Easter Sunday. 449 | 450 | In the Christian world, Easter (and the days immediately preceding it) 451 | is the celebration of the death and resurrection of Jesus in 452 | (approximately) AD 30. *) 453 | 454 | val carnaval: year -> t 455 | (** Carnaval Monday. [carnaval y] is [easter y - 48]. 456 | @since 1.09.0 *) 457 | 458 | val mardi_gras: year -> t 459 | (** Mardi Gras. [mardi_gras y] is [easter y - 47]. 460 | @since 1.09.0 *) 461 | 462 | val ash: year -> t 463 | (** Ash Wednesday. [ash y] is [easter y - 46]. 464 | @since 1.09.0 *) 465 | 466 | val palm: year -> t 467 | (** Palm Sunday. [palm y] is [easter y - 7]. 468 | @since 1.09.0 *) 469 | 470 | val easter_friday: year -> t 471 | (** Easter Friday. [easter_friday y] is [easter y - 2]. 472 | @since 1.09.0 *) 473 | 474 | val easter_saturday: year -> t 475 | (** Easter Saturday. [easter_saturday y] is [easter y - 1]. 476 | @since 1.09.0 *) 477 | 478 | val easter_monday: year -> t 479 | (** Easter Monday. [easter_monday y] is [easter y + 1]. 480 | @since 1.09.0 *) 481 | 482 | val ascension: year -> t 483 | (** Ascension. [ascension y] is [easter y + 39]. 484 | @since 1.09.0 *) 485 | 486 | val withsunday: year -> t 487 | (** Withsunday. [withsunday y] is [easter y + 49]. 488 | @since 1.09.0 *) 489 | 490 | val withmonday: year -> t 491 | (** Withmonday. [withmonday y] is [easter y + 50]. 492 | @since 1.09.0 *) 493 | 494 | val corpus_christi: year -> t 495 | (** Feast of Corpus Christi. [corpus_christi y] is [easter + 60]. 496 | @since 1.09.0 *) 497 | 498 | end 499 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name calendarLib) 4 | (public_name calendar) 5 | (libraries re unix) 6 | (modules_without_implementation calendar_sig date_sig period time_sig) 7 | (flags :standard -warn-error -32 -safe-string)) 8 | 9 | (rule 10 | (targets version.ml) 11 | (action 12 | (with-stdout-to %{targets} 13 | (echo "let version = String.trim \"" %{version:calendar} "\"\n")))) 14 | 15 | -------------------------------------------------------------------------------- /src/fcalendar.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | include Calendar_builder.Make(Date)(Ftime) 24 | 25 | module Precise = Calendar_builder.Make_Precise(Date)(Ftime) 26 | -------------------------------------------------------------------------------- /src/fcalendar.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Calendar implementation in which seconds are float. 24 | 25 | This module uses float. Then results may be very unprecise, especially 26 | comparison of calendars which differ with few seconds. 27 | In this case, consider to use module [Precise]. 28 | @since 2.0 *) 29 | 30 | include Calendar_sig.S with module Date = Date and module Time = Ftime 31 | 32 | (** More precise implementation of calendar in which seconds are float. 33 | @since 2.0 *) 34 | module Precise: Calendar_sig.S with module Date = Date and module Time = Ftime 35 | -------------------------------------------------------------------------------- /src/ftime.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*S Introduction. 24 | 25 | A time is represents by a number of seconds in UTC. 26 | Outside this module, a time is interpreted in the current time zone. 27 | So, each operations have to coerce a given time according to the current 28 | time zone. *) 29 | 30 | (*S Datatypes. *) 31 | 32 | include Utils.Float 33 | 34 | type second = float 35 | 36 | type field = [ `Hour | `Minute | `Second ] 37 | 38 | (*S Conversions. *) 39 | 40 | let one_day = 86400 41 | let fone_day = 86400. 42 | 43 | let convert t t1 t2 = t +. float (3600 * Time_Zone.gap t1 t2) 44 | 45 | let from_gmt t = convert t Time_Zone.UTC (Time_Zone.current ()) 46 | let to_gmt t = convert t (Time_Zone.current ()) Time_Zone.UTC 47 | 48 | (* Coerce [t] into the interval $[0; 86400[$ (i.e. a one day interval). *) 49 | let normalize t = 50 | let t = from_gmt t in 51 | let t_mod, t_div = to_gmt (mod_float t fone_day), int_of_float t / one_day in 52 | if t < 0. then t_mod +. fone_day, t_div - 1 else t_mod, t_div 53 | 54 | (*S Constructors. *) 55 | 56 | let make h m s = to_gmt (float (h * 3600 + m * 60) +. s) 57 | 58 | let lmake ?(hour = 0) ?(minute = 0) ?(second = 0.) () = make hour minute second 59 | 60 | let midnight () = to_gmt 0. 61 | 62 | let midday () = to_gmt 43200. 63 | 64 | let now () = 65 | let now = Unix.gettimeofday () in 66 | let gmnow = Unix.gmtime now in 67 | let frac, _ = modf now in 68 | float 69 | (3600 * gmnow.Unix.tm_hour + 60 * gmnow.Unix.tm_min + gmnow.Unix.tm_sec) 70 | +. frac 71 | 72 | (*S Getters. *) 73 | 74 | let hour t = int_of_float (from_gmt t) / 3600 75 | let minute t = int_of_float (from_gmt t) mod 3600 / 60 76 | let second t = mod_float (from_gmt t) 60. 77 | 78 | let to_hours t = from_gmt t /. 3600. 79 | let to_minutes t = from_gmt t /. 60. 80 | let to_seconds t = from_gmt t 81 | 82 | (*S Boolean operations. *) 83 | 84 | let is_pm t = 85 | let t, _ = normalize t in 86 | let m, _ = normalize (midday ()) in 87 | t < m 88 | 89 | let is_am t = 90 | let t, _ = normalize t in 91 | let m, _ = normalize (midday ()) in 92 | t >= m 93 | 94 | (*S Coercions. *) 95 | 96 | let from_hours t = to_gmt (t *. 3600.) 97 | let from_minutes t = to_gmt (t *. 60.) 98 | let from_seconds t = to_gmt t 99 | 100 | (*S Seconds. *) 101 | 102 | module Second = struct 103 | type t = second 104 | let from_int = float 105 | let to_int = int_of_float 106 | let from_float x = x 107 | let to_float x = x 108 | end 109 | 110 | (*S Period. *) 111 | 112 | module Period = struct 113 | 114 | type +'a period = float constraint 'a = [< Period.date_field ] 115 | include Utils.Float 116 | 117 | let make h m s = float (h * 3600 + m * 60) +. s 118 | let lmake ?(hour=0) ?(minute=0) ?(second=0.) () = make hour minute second 119 | 120 | let length x = x 121 | 122 | let hour x = float (x * 3600) 123 | let minute x = float (x * 60) 124 | let second x = x 125 | 126 | let empty = 0. 127 | 128 | let add = (+.) 129 | let sub = (-.) 130 | let mul = ( *. ) 131 | let div = (/.) 132 | 133 | let opp x = -. x 134 | 135 | let to_seconds x = x 136 | let to_minutes x = x /. 60. 137 | let to_hours x = x /. 3600. 138 | 139 | end 140 | 141 | (*S Arithmetic operations on times and periods. *) 142 | 143 | let add = (+.) 144 | let sub = (-.) 145 | let rem = (-.) 146 | 147 | let next x = function 148 | | `Hour -> x +. 3600. 149 | | `Minute -> x +. 60. 150 | | `Second -> x +. 1. 151 | 152 | let prev x = function 153 | | `Hour -> x -. 3600. 154 | | `Minute -> x -. 60. 155 | | `Second -> x -. 1. 156 | -------------------------------------------------------------------------------- /src/ftime.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Time implementation in which seconds are floats. 24 | 25 | This module uses float. Then results may be very unprecise. 26 | @since 2.0 *) 27 | 28 | include Time_sig.S with type second = float 29 | -------------------------------------------------------------------------------- /src/period.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** A period represents the time passed between two events (a date, a time...). 24 | Only an interface defining arithmetic operations on periods is defined here. 25 | An implementation of this interface depends on the kind of an event (see 26 | module [Time.Period], [Date.Period] and [Calendar.Period]). *) 27 | 28 | type date_field = [ `Year | `Month | `Week | `Day ] 29 | 30 | (** Common interface for all periods. *) 31 | module type S = sig 32 | 33 | type +'a period constraint 'a = [< date_field ] 34 | type t = date_field period 35 | (** Type of a period. *) 36 | 37 | (** {3 Period is an additive monoid} *) 38 | 39 | val empty : 'a period 40 | (** The empty period. *) 41 | 42 | val add : 'a period -> 'a period -> 'a period 43 | (** Addition of periods. *) 44 | 45 | val sub : 'a period -> 'a period -> 'a period 46 | (** Substraction of periods. *) 47 | 48 | val opp : 'a period -> 'a period 49 | (** Opposite of a period. *) 50 | 51 | (** {3 Periods are comparable} *) 52 | 53 | val equal: 'a period -> 'b period -> bool 54 | (** Equality function between two periods. 55 | @see Utils.Comparable.equal 56 | @since 1.09.0 *) 57 | 58 | val compare : 'a period -> 'b period -> int 59 | (** Comparison function between two periods. 60 | @see Utils.Comparable.compare *) 61 | 62 | val hash: 'a period -> int 63 | (** Hash function for periods. 64 | @see Utils.Comparable.hash 65 | @since 2.0 *) 66 | 67 | end 68 | -------------------------------------------------------------------------------- /src/printer.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Pretty printing and parsing from string. 24 | In the following, an "event" is either a date or a time or a calendar. 25 | 26 | This module implements different printers: one for each kind of events. 27 | The three printers have the same signature: 28 | they mainly implement a [fprint : string -> formatter -> t -> unit] function 29 | and a [from_fstring : string -> string -> t] function. 30 | The first one prints an event according to a format string 31 | (see below for a description of such a format). 32 | The second one converts a string to an event according to a format string. 33 | 34 | A format string follows the unix utility 'date' (with few modifications). 35 | It is a string which contains two types of objects: plain characters and 36 | conversion specifiers. Those specifiers are introduced by 37 | a [%] character and their meanings are: 38 | - [%%]: a literal [%] 39 | - [%a]: short day name (by using a short version of [day_name]) 40 | - [%A]: day name (by using [day_name]) 41 | - [%b]: short month name (by using a short version of [month_name]) 42 | - [%B]: month name (by using [month_name]) 43 | - [%c]: shortcut for [%a %b %d %H:%M:%S %Y] 44 | - [%C]: century: as %Y without the two last digits (since version 2.01) 45 | - [%d]: day of month (01..31) 46 | - [%D]: shortcut for [%m/%d/%y] 47 | - [%e]: same as [%_d] 48 | - [%F]: shortcut for [%Y-%m-%d]: ISO-8601 notation (since version 2.01) 49 | - [%h]: same as [%b] 50 | - [%H]: hour (00..23) 51 | - [%I]: hour (01..12) 52 | - [%i]: same as [%F]; deprecated since 2.01 53 | - [%j]: day of year (001..366) 54 | - [%k]: same as [%_H] 55 | - [%l]: same as [%_I] 56 | - [%m]: month (01..12) 57 | - [%M]: minute (00..59) 58 | - [%n]: a newline (same as [\n]) 59 | - [%p]: AM or PM 60 | - [%P]: am or pm (same as %p in lowercase) (since version 2.01) 61 | - [%r]: shortcut for [%I:%M:%S %p] 62 | - [%R]: shortcut for [%H:%M] (since version 2.01) 63 | - [%s]: number of seconds since 1970/1/1 (since version 2.01) 64 | - [%S]: second (00..60) 65 | - [%t]: a horizontal tab (same as [\t]) 66 | - [%T]: shortcut for [%H:%M:%S] 67 | - [%V]: week number of year (01..53) 68 | - [%w]: day of week (1..7) 69 | - [%W]: same as [%V] 70 | - [%y]: last two digits of year (00..99) 71 | - [%Y]: year (four digits) 72 | - [%z]: time zone in the form +hhmm (e.g. -0400) (since version 2.01) 73 | - [%:z]: time zone in the form +hh:mm (e.g. -04:00) (since version 2.01) 74 | - [%::z]: time zone in the form +hh:mm:ss (e.g. -04:00:00) 75 | (since version 2.01) 76 | - [%:::z]: time zone in the form +hh (e.g. -04) (since version 2.01) 77 | 78 | By default, date pads numeric fields with zeroes. Two special modifiers 79 | between [`%'] and a numeric directive are recognized: 80 | - ['-' (hyphen)]: do not pad the field 81 | - ['_' (underscore)]: pad the field with spaces 82 | - ['0' (zero)]: pad the field with zeroes (default) (since version 2.01) 83 | - ['^']: use uppercase if possible (since version 2.01) 84 | Padding is only available for printers, not for parsers. 85 | 86 | @example a possible output of [%D] is [01/06/03] 87 | @example a possible output of [the date is %B, the %-dth] is 88 | [the date is January, the 6th] is matched by ; 89 | @example a possible output of [%c] is [Thu Sep 18 14:10:51 2003]. 90 | 91 | @since 1.05 *) 92 | 93 | (** {2 Internationalization} 94 | 95 | You can manage the string representations of days and months. 96 | By default, the English names are used but you can change their by 97 | setting the references [day_name] and [month_name]. 98 | 99 | @example 100 | [day_name := function Date.Mon -> "lundi" | Date.Tue -> "mardi" | 101 | Date.Wed -> "mercredi" | Date.Thu -> "jeudi" | Date.Fri -> "vendredi" | 102 | Date.Sat -> "samedi" | Date.Sun -> "dimanche"] 103 | sets the names of the days to the French names. *) 104 | 105 | val day_name : (Date.day -> string) ref 106 | (** String representation of a day. *) 107 | 108 | val name_of_day : Date.day -> string 109 | (** [name_of_day d] is equivalent to [!day_name d]. 110 | Used by the specifier [%A]. *) 111 | 112 | val short_name_of_day : Date.day -> string 113 | (** [short_name_of_day d] returns the 3 first characters of [name_of_day d]. 114 | Used by the specifier [%a]. *) 115 | 116 | val month_name : (Date.month -> string) ref 117 | (** String representation of a month. *) 118 | 119 | val name_of_month : Date.month -> string 120 | (** [name_of_month m] is equivalent to [!day_month m]. 121 | Used by the specifier [%B]. *) 122 | 123 | val short_name_of_month : Date.month -> string 124 | (** [short_name_of_month d] returns the 3 first characters of 125 | [name_of_month d]. 126 | Used by the specifier [%b]. *) 127 | 128 | val set_word_regexp: Re.Str.regexp -> unit 129 | (** Set the regular expression used to recognize words in 130 | [from_fstring]. Default is [[a-zA-Z]*]. 131 | @since 1.10 *) 132 | 133 | (** {2 Printers (including parsers from string)} 134 | 135 | Printers also contain parsers which allow to build events from strings. *) 136 | 137 | (** Generic signature of a printer-parser. *) 138 | module type S = sig 139 | 140 | type t 141 | (** Generic type of a printer. *) 142 | 143 | val fprint : string -> Format.formatter -> t -> unit 144 | (** [fprint format formatter x] outputs [x] on [formatter] according to 145 | the specified [format]. 146 | @raise Invalid_argument if the format is incorrect. *) 147 | 148 | val print : string -> t -> unit 149 | (** [print format] is equivalent to [fprint format Format.std_formatter] *) 150 | 151 | val dprint : t -> unit 152 | (** Same as [print d] where [d] is the default format 153 | (see the printer implementations). *) 154 | 155 | val sprint : string -> t -> string 156 | (** [sprint format date] converts [date] to a string according to 157 | [format]. *) 158 | 159 | val to_string : t -> string 160 | (** Same as [sprint d] where [d] is the default format 161 | (see the printer implementations). *) 162 | 163 | (** {3 Parsers from string} *) 164 | 165 | val from_fstring : string -> string -> t 166 | (** [from_fstring format s] converts [s] to a date according to [format]. 167 | 168 | Date padding (i.e. a special directive following ['%']) and 169 | specifiers [%e], [%k] and [%l] are not recognized. Specifiers 170 | [%a], [%A], [%j], [%v], [%w] and [%W] are recognized but mainly ignored: 171 | only the validity of the format is checked. 172 | 173 | In order to recognize words (used by [%a], [%A], [%b], [%B] and [%p]), a 174 | regular expression is used which can be configured by 175 | {!Printer.set_word_regexp}. When the format has only two digits for the 176 | year number, 1900 are added to this number (see examples). 177 | 178 | @raise Invalid_argument if either the format is incorrect or the string 179 | does not match the format or the event cannot be created (e.g. if you do 180 | not specify a year for a date). 181 | 182 | @example [from_fstring "the date is %D" "the date is 01/06/03"] 183 | returns a date equivalent to [Date.make 1903 1 6] 184 | @example [from_fstring "the date is %B, the %dth %Y" "the date is May, 185 | the 14th 2007"] returns a date equivalent to [Date.make 2007 5 14] (with 186 | default internationalization). *) 187 | 188 | val from_string : string -> t 189 | (** Same as [from_fstring d] where [d] is the default format. *) 190 | 191 | end 192 | 193 | (** Date printer. Specifiers which use time functionalities are not available 194 | on this printer. 195 | Default format is [%i]. 196 | @since 2.0 *) 197 | module Date: S with type t = Date.t 198 | 199 | (** @deprecated Replaced by {!Printer.Date}. *) 200 | module DatePrinter: S with type t = Date.t 201 | 202 | (** Time printer. Specifiers which use date functionalities are not available 203 | on this printer. 204 | Default format is [%T]. 205 | @since 2.0 *) 206 | module Time: S with type t = Time.t 207 | 208 | (** @deprecated Replaced by {!Printer.Time}. *) 209 | module TimePrinter : S with type t = Time.t 210 | 211 | (** Ftime printer. Seconds are rounded to integers before pretty printing. 212 | Specifiers which use date functionalities are not available 213 | on this printer. 214 | Default format is [%T]. 215 | @since 2.0 *) 216 | module Ftime: S with type t = Ftime.t 217 | 218 | (** Precise Calendar printer. Default format is [%i %T]. 219 | @since 2.0 *) 220 | module Precise_Calendar: S with type t = Calendar.Precise.t 221 | 222 | (** Calendar printer. Default format is [%i %T]. 223 | @since 2.0 *) 224 | module Calendar: S with type t = Calendar.t 225 | 226 | (** @deprecated Replaced by {!Printer.Calendar}. *) 227 | module CalendarPrinter: S with type t = Calendar.t 228 | 229 | (** Precise Fcalendar printer. 230 | Seconds are rounded to integers before pretty printing. 231 | Default format is [%i %T]. 232 | @since 2.0 *) 233 | module Precise_Fcalendar: S with type t = Fcalendar.Precise.t 234 | 235 | (** Fcalendar printer. Seconds are rounded to integers before pretty printing. 236 | Default format is [%i %T]. 237 | @since 2.0 *) 238 | module Fcalendar: S with type t = Fcalendar.t 239 | -------------------------------------------------------------------------------- /src/time.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*S Introduction. 24 | 25 | A time is represents by a number of seconds in UTC. 26 | Outside this module, a time is interpreted in the current time zone. 27 | So, each operations have to coerce a given time according to the current 28 | time zone. *) 29 | 30 | (*S Datatypes. *) 31 | 32 | include Utils.Int 33 | 34 | type second = int 35 | 36 | type field = [ `Hour | `Minute | `Second ] 37 | 38 | (*S Conversions. *) 39 | 40 | let one_day = 86400 41 | 42 | let convert t t1 t2 = t + 3600 * Time_Zone.gap t1 t2 43 | let from_gmt t = convert t Time_Zone.UTC (Time_Zone.current ()) 44 | let to_gmt t = convert t (Time_Zone.current ()) Time_Zone.UTC 45 | 46 | (* Coerce [t] into the interval $[0; 86400[$ (i.e. a one day interval). *) 47 | let normalize t = 48 | let t = from_gmt t in 49 | let t_mod, t_div = to_gmt (t mod one_day), t / one_day in 50 | if t < 0 then t_mod + one_day, t_div - 1 else t_mod, t_div 51 | 52 | (*S Constructors. *) 53 | 54 | let make h m s = to_gmt (h * 3600 + m * 60 + s) 55 | let lmake ?(hour = 0) ?(minute = 0) ?(second = 0) () = make hour minute second 56 | 57 | let midnight () = to_gmt 0 58 | 59 | let midday () = to_gmt 43200 60 | 61 | let now () = 62 | let now = Unix.gmtime (Unix.time ()) in 63 | 3600 * now.Unix.tm_hour + 60 * now.Unix.tm_min + now.Unix.tm_sec 64 | 65 | (*S Getters. *) 66 | 67 | let hour t = from_gmt t / 3600 68 | let minute t = from_gmt t mod 3600 / 60 69 | let second t = from_gmt t mod 60 70 | 71 | let to_hours t = float (from_gmt t) /. 3600. 72 | let to_minutes t = float (from_gmt t) /. 60. 73 | let to_seconds t = from_gmt t 74 | 75 | (*S Boolean operations. *) 76 | 77 | let is_pm t = 78 | let t, _ = normalize t in 79 | let m, _ = normalize (midday ()) in 80 | t < m 81 | 82 | let is_am t = 83 | let t, _ = normalize t in 84 | let m, _ = normalize (midday ()) in 85 | t >= m 86 | 87 | (*S Coercions. *) 88 | 89 | let from_hours t = to_gmt (int_of_float (t *. 3600.)) 90 | let from_minutes t = to_gmt (int_of_float (t *. 60.)) 91 | let from_seconds t = to_gmt t 92 | 93 | (*S Seconds. *) 94 | 95 | module Second = struct 96 | type t = second 97 | let from_int x = x 98 | let to_int x = x 99 | let from_float = Utils.Float.round 100 | let to_float = float 101 | end 102 | 103 | (*S Period. *) 104 | 105 | module Period = struct 106 | 107 | type +'a period = int constraint 'a = [< Period.date_field ] 108 | include Utils.Int 109 | 110 | let make h m s = h * 3600 + m * 60 + s 111 | let lmake ?(hour=0) ?(minute=0) ?(second=0) () = make hour minute second 112 | 113 | let length x = x 114 | 115 | let hour x = x * 3600 116 | let minute x = x * 60 117 | let second x = x 118 | 119 | let empty = 0 120 | 121 | let add = (+) 122 | let sub = (-) 123 | let mul = ( * ) 124 | let div = (/) 125 | 126 | let opp x = - x 127 | 128 | let to_seconds x = x 129 | let to_minutes x = float x /. 60. 130 | let to_hours x = float x /. 3600. 131 | 132 | end 133 | 134 | (*S Arithmetic operations on times and periods. *) 135 | 136 | let add = (+) 137 | let sub = (-) 138 | let rem = (-) 139 | 140 | let next x = function 141 | | `Hour -> x + 3600 142 | | `Minute -> x + 60 143 | | `Second -> x + 1 144 | 145 | let prev x = function 146 | | `Hour -> x - 3600 147 | | `Minute -> x - 60 148 | | `Second -> x - 1 149 | -------------------------------------------------------------------------------- /src/time.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Time implementation in which seconds are integers. *) 24 | 25 | include Time_sig.S with type second = int 26 | -------------------------------------------------------------------------------- /src/time_Zone.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | type t = 24 | | UTC 25 | | Local 26 | | UTC_Plus of int 27 | 28 | let tz = ref UTC 29 | 30 | let out_of_bounds x = x < - 12 || x > 11 31 | 32 | let in_bounds x = not (out_of_bounds x) 33 | 34 | let make_in_bounds x = 35 | let y = x mod 24 in 36 | if y < -12 then y + 24 37 | else if y > 11 then y - 24 38 | else y 39 | 40 | let gap_gmt_local = 41 | let t = Unix.time () in 42 | (Unix.localtime t).Unix.tm_hour - (Unix.gmtime t).Unix.tm_hour 43 | 44 | let current () = !tz 45 | 46 | let change = function 47 | | _ as t -> tz := t 48 | 49 | let gap t1 t2 = 50 | let aux t1 t2 = 51 | assert (t1 < t2); 52 | match t1, t2 with 53 | | UTC, Local -> gap_gmt_local 54 | | UTC, UTC_Plus x -> x 55 | | Local, UTC_Plus x -> x - gap_gmt_local 56 | | UTC_Plus x, UTC_Plus y -> y - x 57 | | _ -> assert false 58 | in 59 | let res = 60 | if t1 = t2 then 0 61 | else if t1 < t2 then aux t1 t2 62 | else - aux t2 t1 63 | in 64 | make_in_bounds res 65 | 66 | let from_gmt () = gap UTC (current ()) 67 | let to_gmt () = gap (current ()) UTC 68 | 69 | let is_dst () = 70 | current () = Local && (Unix.localtime (Unix.time ())).Unix.tm_isdst 71 | 72 | let hour_of_dst () = if is_dst () then 1 else 0 73 | 74 | let on f tz x = 75 | let old = current () in 76 | change tz; 77 | try 78 | let res = f x in 79 | change old; 80 | res 81 | with exn -> 82 | change old; 83 | raise exn 84 | -------------------------------------------------------------------------------- /src/time_Zone.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Time zone management. 24 | 25 | You can [change] the [current] time zone in your program by side effect. *) 26 | 27 | (** Type of a time zone. *) 28 | type t = 29 | | UTC (** Greenwich Meridian Time *) 30 | | Local (** Local Time *) 31 | | UTC_Plus of int (** Another time zone specified from UTC *) 32 | 33 | val current : unit -> t 34 | (** Return the current time zone. It is [UTC] before any change. *) 35 | 36 | val change : t -> unit 37 | (** Change the current time zone by another one. 38 | Raise [Invalid_argument] if the specified time zone is [UTC_Plus x] with 39 | [x < -12] or [x > 11] *) 40 | 41 | val gap : t -> t -> int 42 | (** Return the gap between two time zone. 43 | @example [gap UTC (UTC_Plus 5)] returns 5 and, at Paris in summer, 44 | [gap Local UTC] returns -2. *) 45 | 46 | val from_gmt : unit -> int 47 | (** [from_gmt ()] is equivalent to [gap UTC (current ())]. *) 48 | 49 | val to_gmt : unit -> int 50 | (** [to_gmt ()] is equivalent to [gap (current ()) UTC]. *) 51 | 52 | val is_dst : unit -> bool 53 | (** [is_dst ()] checks if daylight saving time is in effect. 54 | Only relevant in local time. 55 | Returns alway [false] in another time zone. 56 | @since 1.09.4 *) 57 | 58 | val hour_of_dst : unit -> int 59 | (** [hour_of_dst ()] returns [1] if [is_dst ()] and [0] otherwise. 60 | @since 1.09.4 *) 61 | 62 | val on: ('a -> 'b) -> t -> 'a -> 'b 63 | (** [on f tz x] changes the time zone to [tz], then computes [f x], and 64 | finally reset the time zone to the initial one and returns the result of 65 | the computation. 66 | @since 2.0 *) 67 | -------------------------------------------------------------------------------- /src/time_sig.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Time interface. A time may be seen as a triple (hour, minute, second). 24 | 25 | If minutes and seconds do not belong to [\[0; 60\[], they are coerced into 26 | this interval. 27 | 28 | @example "30 hours, 60 minutes, 80 seconds" is coerced to "31 hours, 1 29 | minute, 20 seconds". 30 | 31 | Each time is interpreted in the current time zone (given by 32 | [Time_Zone.current ()]). So, if you change the time zone (by 33 | {!Time_Zone.change}), each time consequently changes. 34 | If you want to express a time in another time zone (and do not affect 35 | others times), use the [convert] function. *) 36 | 37 | (** Interface for seconds. 38 | @since 2.0 *) 39 | module type Second = sig 40 | 41 | type t 42 | (** Type of seconds. *) 43 | 44 | val from_int: int -> t 45 | (** Convert an integer to an equivalent number of seconds. *) 46 | 47 | val from_float: float -> t 48 | (** Convert a float to an equivalent number of seconds. *) 49 | 50 | val to_int: t -> int 51 | (** Inverse of [from_int]. *) 52 | 53 | val to_float: t -> float 54 | (** Inverse of [from_float]. *) 55 | 56 | end 57 | 58 | (** Common operations for all time representations. 59 | @since 2.0 (this signature was before inlined in interface of Time). *) 60 | module type S = sig 61 | 62 | (** {2 Datatypes} *) 63 | 64 | type t 65 | (** Type of a time. *) 66 | 67 | type field = [ `Hour | `Minute | `Second ] 68 | (** The different fields of a time. *) 69 | 70 | (** {2 Second} *) 71 | 72 | type second 73 | (** Type of a second. 74 | @since 2.0 (was an integer in previous versions). *) 75 | 76 | (** Second implementation 77 | @since 2.0 *) 78 | module Second: Second with type t = second 79 | 80 | (** {2 Constructors} *) 81 | 82 | val make : int -> int -> second -> t 83 | (** [make hour minute second] makes the time hour-minute-second. *) 84 | 85 | val lmake : ?hour:int -> ?minute:int -> ?second:second -> unit -> t 86 | (** Labelled version of [make]. The default value is [0] for each argument. 87 | @since 1.05 *) 88 | 89 | val now : unit -> t 90 | (** The current time based on [Time_Zone.current ()]. *) 91 | 92 | val midnight : unit -> t 93 | (** [midnight ()] is midnight (expressed in the current time zone). 94 | So, it has always the same behaviour as [make 0 0 0]. *) 95 | 96 | val midday : unit -> t 97 | (** [midday ()] is midday (expressed in the current time zone). 98 | So, it has always the same behaviour as [make 12 0 0]. *) 99 | 100 | (** {2 Conversions} *) 101 | 102 | val convert : t -> Time_Zone.t -> Time_Zone.t -> t 103 | (** [convert t t1 t2] converts the time [t] expressed in the time zone [t1] 104 | to the same time expressed in the time zone [t2]. 105 | @example [convert (make 20 0 0) (Time_Zone.GMT_Plus 2) 106 | (Time_Zone.GMT_Plus 4)] returns the time 22-0-0. *) 107 | 108 | val from_gmt : t -> t 109 | (** [from_gmt t] is equivalent to 110 | [convert t Time_Zone.GMT (Time_Zone.current ())]. *) 111 | 112 | val to_gmt : t -> t 113 | (** [to_gmt t] is equivalent to 114 | [convert t (Time_Zone.current ()) Time_Zone.GMT]. *) 115 | 116 | val normalize : t -> t * int 117 | (** [normalize t] returns [t] such that [hour t] belongs to [\[0; 24\[]. The 118 | second component of the result is the number of days needed by the 119 | modification. 120 | @example [normalize (make 22 0 0)] returns the time 22-0-0 and 0, 121 | [normalize (make 73 0 0)] returns the time 1-0-0 and 3 and [normalize 122 | (make (-73) 0 0)] returns the time 23-0-0 and (-4). *) 123 | 124 | (** {2 Getters} *) 125 | 126 | val hour : t -> int 127 | (** Hour. 128 | @example [hour (make 20 0 0)] returns 20. *) 129 | 130 | val minute : t -> int 131 | (** Minute. 132 | @example [minute (make 20 10 0)] returns 10. *) 133 | 134 | val second : t -> second 135 | (** Second. 136 | @example [second (make 20 10 5)] returns 5. *) 137 | 138 | val to_seconds : t -> second 139 | (** Number of seconds of a time. 140 | @example [to_seconds (make 1 2 3)] returns [3600 + 120 + 3 = 3723]. *) 141 | 142 | val to_minutes : t -> float 143 | (** Number of minutes of a time. The resulting fractional part represents 144 | seconds. 145 | @example [to_minutes (make 1 2 3)] returns [60+2+0.05 = 62.05]. *) 146 | 147 | val to_hours : t -> float 148 | (** Number of hours of a time. The resulting fractional part represents 149 | minutes and seconds. 150 | @example [to_hours (make 1 3 0)] returns [1 + 0.05 = 1.05]. *) 151 | 152 | (** {2 Times are comparable} *) 153 | 154 | val equal: t -> t -> bool 155 | (** Equality function between two times. 156 | @see Utils.Comparable.equal. 157 | @since 1.09.0 *) 158 | 159 | val compare : t -> t -> int 160 | (** Comparison function between two times. 161 | @see Utils.Comparable.compare. *) 162 | 163 | val hash: t -> int 164 | (** Hash function for times. 165 | @see Utils.Comparable.hash. 166 | @since 2.0 *) 167 | 168 | (** {2 Boolean operations on times} *) 169 | 170 | val is_pm : t -> bool 171 | (** Return [true] is the time is before midday in the current time zone; 172 | [false] otherwise. 173 | @example both [is_pm (make 10 0 0)] and [is_pm (make 34 0 0)] return 174 | [true]. *) 175 | 176 | val is_am : t -> bool 177 | (** Return [true] is the time is after midday in the current time zone; 178 | [false] otherwise. 179 | @example both [is_am (make 20 0 0)] and [is_am (make 44 0 0)] return 180 | [true]. *) 181 | 182 | (** {2 Coercions} *) 183 | 184 | val from_seconds: second -> t 185 | (** Inverse of [to_seconds]. *) 186 | 187 | val from_minutes: float -> t 188 | (** Inverse of [to_minutes]. *) 189 | 190 | val from_hours: float -> t 191 | (** Inverse of [to_hours]. *) 192 | 193 | (** {2 Period} *) 194 | 195 | (** A period is the number of seconds between two times. *) 196 | module Period : sig 197 | 198 | (** {3 Arithmetic operations} *) 199 | 200 | include Period.S 201 | 202 | val length : 'a period -> second 203 | (** Number of seconds of a period. *) 204 | 205 | val mul : 'a period -> 'a period -> 'a period 206 | (** Multiplication. *) 207 | 208 | val div : 'a period -> 'a period -> 'a period 209 | (** Division. *) 210 | 211 | (** {3 Constructors} *) 212 | 213 | val make : int -> int -> second -> 'a period 214 | (** [make hour minute second] makes a period of the specified length. *) 215 | 216 | val lmake : ?hour:int -> ?minute:int -> ?second:second -> unit -> 'a period 217 | (** Labelled version of [make]. 218 | The default value is [0] for each argument. *) 219 | 220 | val hour : int -> 'a period 221 | (** [hour n] makes a period of [n] hours. *) 222 | 223 | val minute : int -> 'a period 224 | (** [minute n] makes a period of [n] minutes. *) 225 | 226 | val second : second -> 'a period 227 | (** [second n] makes a period of [n] seconds. *) 228 | 229 | (** {3 Getters} *) 230 | 231 | val to_seconds : 'a period -> second 232 | (** Number of seconds of a period. 233 | @example [to_seconds (make 1 2 3)] returns [3600 + 120 + 3 = 3723]. 234 | @since 1.04 *) 235 | 236 | val to_minutes : 'a period -> float 237 | (** Number of minutes of a period. The resulting fractional part 238 | represents seconds. 239 | @example [to_minutes (make 1 2 3)] returns [60 + 2 + 0.05 = 62.05]. 240 | @since 1.04 *) 241 | 242 | val to_hours : 'a period -> float 243 | (** Number of hours of a period. The resulting fractional part represents 244 | minutes and seconds. 245 | @example [to_hours (make 1 3 0)] returns [1 + 0.05 = 1.05]. 246 | @since 1.04 *) 247 | 248 | end 249 | 250 | (** {2 Arithmetic operations on times and periods} *) 251 | 252 | val add : t -> 'a Period.period -> t 253 | (** [app t p] returns [t + p]. 254 | @example [add (make 20 0 0) (Period.minute 70)] returns the time 255 | 21:10:0. *) 256 | 257 | val sub : t -> t -> 'a Period.period 258 | (** [sub t1 t2] returns the period between [t1] and [t2]. *) 259 | 260 | val rem : t -> 'a Period.period -> t 261 | (** [rem t p] is equivalent to [add t (Period.opp p)]. *) 262 | 263 | val next : t -> field -> t 264 | (** [next t f] returns the time corresponding to the next specified field. 265 | @example [next (make 20 3 31) `Minute] returns the time 20:04:31. 266 | (i.e. one minute later). *) 267 | 268 | val prev : t -> field -> t 269 | (** [prev t f] returns the time corresponding to the previous specified 270 | field. 271 | @example [prev (make 20 3 31) `Second] returns the time 20:03:30 272 | (i.e. one second ago). *) 273 | 274 | end 275 | -------------------------------------------------------------------------------- /src/utils.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | module type Comparable = sig 24 | type t 25 | val equal: t -> t -> bool 26 | val compare: t -> t -> int 27 | val hash: t -> int 28 | end 29 | 30 | module Int = struct 31 | type t = int 32 | let equal (a: int) b = a = b 33 | let compare (a: int) b = compare a b 34 | let hash = Hashtbl.hash 35 | end 36 | 37 | module Float = struct 38 | 39 | type t = float 40 | 41 | let precision = ref 1e-8 42 | 43 | let set_precision f = precision := f 44 | 45 | let equal x y = abs_float (x -. y) < !precision 46 | 47 | let compare x y = 48 | if equal x y then 0 49 | else if x < y then -1 50 | else 1 51 | 52 | let hash = Hashtbl.hash 53 | 54 | let round x = 55 | let f, i = modf x in 56 | int_of_float i + (if f < 0.5 then 0 else 1) 57 | 58 | end 59 | -------------------------------------------------------------------------------- /src/utils.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Some utilities. 24 | @since 2.0 *) 25 | 26 | (** Interface for comparable and hashable types. 27 | Modules implementing this interface can be an argument of [Map.Make], 28 | [Set.Make] or [Hashtbl.Make]. 29 | @since 2.0 *) 30 | module type Comparable = sig 31 | 32 | type t 33 | 34 | val equal: t -> t -> bool 35 | (** Equality over [t]. *) 36 | 37 | val compare: t -> t -> int 38 | (** Comparison over [t]. 39 | [compare x y] returns [0] iff [equal x y = 0]. If [x] and [y] are not 40 | equal, it returns a negative integer iff [x] is lesser than [y] and a 41 | positive integer otherwise. *) 42 | 43 | val hash: t -> int 44 | (** A hash function over [t]. *) 45 | 46 | end 47 | 48 | (** Integer implementation. 49 | @since 2.0 *) 50 | module Int: Comparable with type t = int 51 | 52 | (** Float implementation. 53 | @since 2.0 *) 54 | module Float: sig 55 | 56 | include Comparable with type t = float 57 | 58 | val set_precision: float -> unit 59 | (** Set the precision of [equal] and [compare] for float. 60 | If the precision is [p], then the floats [x] and [y] are equal iff 61 | [abs(x-y) < p]. By default, the precision is [1e-8] (that is 0.864 62 | milliseconds if floats represent days). *) 63 | 64 | val round: t -> int 65 | (** Round a float to the nearest integer. *) 66 | 67 | end 68 | -------------------------------------------------------------------------------- /src/version.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Information about version of calendar. 24 | @since 2.0 *) 25 | 26 | val version: string 27 | (** Name of this version. *) 28 | 29 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | 2 | (executable 3 | (name test) 4 | (libraries calendar alcotest)) 5 | 6 | (alias 7 | (name runtest) 8 | (deps test.exe) 9 | (action (run ./test.exe -e))) 10 | -------------------------------------------------------------------------------- /tests/gen_test.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*i $Id$ i*) 24 | 25 | let ok_ref = ref 0 26 | let ok () = incr ok_ref 27 | let nb_ok () = !ok_ref 28 | 29 | let bug_ref = ref 0 30 | let bug () = incr bug_ref 31 | let nb_bug () = !bug_ref 32 | 33 | let reset () = 34 | ok_ref := 0; 35 | bug_ref := 0 36 | 37 | let test x s = 38 | if x then ok () else begin Printf.printf "%s\n" s; bug () end;; 39 | 40 | let test_exn x s = 41 | try 42 | ignore (Lazy.force x); 43 | Alcotest.failf "expected exception: %s" s 44 | with _ -> 45 | () 46 | -------------------------------------------------------------------------------- /tests/gen_test.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*i $Id$ i*) 24 | 25 | (* Generic functions used in the tests. *) 26 | 27 | val reset : unit -> unit 28 | 29 | val nb_ok : unit -> int 30 | 31 | val nb_bug : unit -> int 32 | 33 | val test : bool -> string -> unit 34 | 35 | val test_exn : 'a Lazy.t -> string -> unit 36 | -------------------------------------------------------------------------------- /tests/test.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*i $Id$ i*) 24 | 25 | (* Display the results *) 26 | 27 | let suite = [ 28 | "timezone", Test_timezone.suite; 29 | "time", Test_time.suite; 30 | "ftime", Test_ftime.suite; 31 | "date", Test_date.suite; 32 | "calendar", Test_calendar.suite; 33 | "pcalendar", Test_pcalendar.suite; 34 | "fpcalendar", Test_fpcalendar.suite; 35 | "printer", Test_printer.suite; 36 | ] 37 | 38 | let () = 39 | Alcotest.run "calendar tests" suite 40 | -------------------------------------------------------------------------------- /tests/test_calendar.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | Printf.printf "Tests of Calendar:\n";; 24 | 25 | open CalendarLib;; 26 | open Calendar;; 27 | 28 | let test() = 29 | let test x s = Alcotest.(check bool) s true x in 30 | let eps = 0.000001 in 31 | 32 | Time_Zone.change Time_Zone.UTC; 33 | 34 | (* Calendar *) 35 | 36 | Gen_test.test_exn (lazy (make (-4712) 1 1 12 0 (-1))) "-4713-12-31-23-59-59"; 37 | test (make (-4712) 1 1 12 0 0 = make (-4712) 1 0 36 0 0) "calendar coercion"; 38 | test (from_jd 0. = make (-4712) 1 1 12 0 0) "from_jd 0 = 4713 BC-1-1"; 39 | test (from_mjd 0. = make 1858 11 17 0 0 0) "from_mjd 0 = 1858-11-17"; 40 | 41 | test (Precise.compare (Precise.make 2009 12 14 13 49 0) (Precise.make 2009 12 14 13 49 1) < 0) 42 | "Precise.compare 2009/12/14/13/19/0 2009/12/14/13/19/1"; 43 | 44 | Utils.Float.set_precision 1e-5; 45 | test (compare (make 2009 12 14 13 49 0) (make 2009 12 14 13 49 1) < 0) 46 | "compare 2009/12/14/13/19/0 2009/12/14/13/19/1"; 47 | Utils.Float.set_precision 1e-3; 48 | 49 | Time_Zone.change (Time_Zone.UTC_Plus 5); 50 | 51 | test (abs_float (to_jd (from_jd 12345.6789) -. 12345.6789) < eps) 52 | "to_jd (from_jd x) = x"; 53 | test (abs_float (to_mjd (from_mjd 12345.6789) -. 12345.6789) < eps) 54 | "to_mjd (from_mjd x) = x"; 55 | test (Period.to_date (Period.hour 60) = Date.Period.day 2) 56 | "period(60h) = period(2d)"; 57 | test (Period.compare (Period.day 2) (Period.hour 60) < 0) "Period.compare <"; 58 | test (Period.compare (Period.day 3) (Period.hour 60) > 0) "Period.compare >"; 59 | test (Period.compare 60 | (Period.add (Period.day 2) (Period.hour 12)) 61 | (Period.hour 60) = 0) "Period.compare ="; 62 | test 63 | (add (make 1 2 3 4 5 6) (Period.make 9 8 7 6 5 4) = make 10 10 10 10 10 10) 64 | "add 1-2-3-4-5-6 9-8-7-6-5-4"; 65 | test 66 | (add (make 3 1 1 0 0 0) (Period.make 0 0 0 (-25) 0 (-1)) = 67 | make 2 12 30 22 59 59) 68 | "add 3-1-1-0-0-0 0-0-0-(-25)-0-(-1)"; 69 | 70 | test 71 | (equal (rem (make 9 8 7 6 5 4) (Period.make 1 2 3 4 5 6)) 72 | (make 8 6 4 1 59 58)) 73 | "rem 9-8-7-6-5-4 1-2-3-4-5-6"; 74 | test (Period.equal 75 | (sub (make 0 0 7 6 5 4) (make 0 0 3 54 5 6)) 76 | (Period.make 0 0 1 23 59 58)) 77 | "sub 0-0-7-6-5-4 0-0-3-54-5-6"; 78 | 79 | test (Date.Period.ymd 80 | (Period.to_date 81 | (precise_sub (make 2010 10 5 0 0 0) (make 2010 6 2 0 0 0))) 82 | = (0, 4, 3)) 83 | "precise_sub 2010-10-5 2010-6-2"; 84 | test (Date.Period.ymd 85 | (Period.to_date 86 | (precise_sub (make 2010 10 5 0 2 3) (make 2010 6 5 0 0 0))) = 87 | (0, 4, 0)) 88 | "precise_sub 2010-10-5 2010-6-2"; 89 | test (Date.Period.ymd 90 | (Period.to_date 91 | (precise_sub (make 2010 10 5 0 32 12) (make 2010 6 6 0 31 3))) 92 | = (0, 3, 29)) 93 | "precise_sub 2010-10-5 2010-6-6"; 94 | test (Date.Period.ymd 95 | (Period.to_date 96 | (precise_sub (make 2010 10 5 1 3 3) (make 2010 6 4 0 23 3))) = 97 | (0, 4, 1)) 98 | "precise_sub 2010-10-5 2010-6-4"; 99 | test (Date.Period.ymd 100 | (Period.to_date 101 | (precise_sub (make 2010 1 1 0 0 0) (make 2000 1 1 0 0 0))) 102 | = (10, 0, 0)) 103 | "precise_sub 2010-1-1 2000-1-1"; 104 | 105 | test (Period.equal 106 | (Period.opp (Period.make 0 0 2 3 0 0)) 107 | (Period.make 0 0 (-2) (-3) 0 0)) 108 | "period opp"; 109 | 110 | (* Date *) 111 | 112 | let d = make 2003 12 31 12 24 48 in 113 | test (next d `Month = make 2004 1 31 12 24 48) "2003-12-31 + 1 mois"; 114 | test (add d (Period.month 2) = make 2004 3 2 12 24 48) "2003-12-31 + 2 mois"; 115 | let d3 = make 2011 3 24 0 0 0 in 116 | test (prev d3 `Year = make 2010 3 24 0 0 0) "2011-3-24 - 1 year"; 117 | let d2 = make (-3000) 1 1 6 12 24 in 118 | test (equal (rem d (sub d d2)) d2) "rem x (sub x y) = y"; 119 | test (is_leap_day (make 2000 2 24 0 0 0)) "2000-2-24 leap day"; 120 | test (not (is_leap_day (make 2000 2 25 0 0 0))) "2000-2-25 not leap day"; 121 | test (is_gregorian (make 1600 1 1 0 0 0)) "1600-1-1 gregorian"; 122 | test (not (is_gregorian (make 1400 1 1 0 0 0))) "1400-1-1 not gregorian"; 123 | test (is_julian (make 1582 1 1 0 0 0)) "1582-1-1 julian"; 124 | test (not (is_julian (make 1583 1 1 0 0 0))) "1583-1-1 not julian"; 125 | 126 | (* Time *) 127 | 128 | test (let n = Unix.gmtime (Unix.time ()) in 129 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant UTC"; 130 | test (let n = Unix.time () in 131 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 132 | "from_unixfloat invariant UTC"; 133 | 134 | Time_Zone.change (Time_Zone.UTC_Plus 10); 135 | 136 | test (let n = Unix.gmtime (Unix.time ()) in 137 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant +10"; 138 | test (let n = Unix.time () in 139 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 140 | "from_unixfloat invariant +10"; 141 | 142 | test (equal (add (make 0 0 0 10 0 0) (Period.hour 30)) (make 0 0 1 16 0 0)) 143 | "add 0-0-0-20-0-0 30h"; 144 | test (equal (next (make 1999 12 31 23 59 59) `Second) (make 2000 1 1 0 0 0)) 145 | "next 1999-31-12-23-59-59 `Second"; 146 | let n = now () in 147 | test (equal (prev (next n `Minute) `Minute) n) "prev next = id"; 148 | test (equal 149 | (convert 150 | (make 0 0 0 23 0 0) 151 | (Time_Zone.UTC_Plus 2) 152 | (Time_Zone.UTC_Plus 4)) 153 | (make 0 0 1 1 0 0)) "convert"; 154 | test (hour (make 0 0 0 20 0 0) = 20) "hour"; 155 | test (minute (make 0 0 0 20 10 0) = 10) "minute"; 156 | test (second (make 0 0 0 20 10 5) = 5) "second"; 157 | test (is_pm (make 0 0 0 10 0 0)) "is_pm 10-0-0"; 158 | test (is_pm (make 0 0 0 34 0 0)) "is_pm 34-0-0"; 159 | test (not (is_pm (make 0 0 0 (- 10) 0 0))) "not (is_pm (- 10) 0 0)"; 160 | test (is_am (make 0 0 0 20 0 0)) "is_am 20-0-0"; 161 | test (is_am (make 0 0 0 (- 34) 0 0)) "is_am (- 34) 0 0"; 162 | test (not (is_am (make 0 0 0 34 0 0))) "not (is_pm 34 0 0)"; 163 | 164 | Time_Zone.change Time_Zone.UTC; 165 | 166 | test (let n = Unix.gmtime (Unix.time ()) in 167 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant UTC2"; 168 | test (let n = Unix.time () in 169 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 170 | "from_unixfloat invariant UTC2"; 171 | 172 | test (to_unixfloat (make 1970 1 1 0 0 0) = 0.) "to_unixfloat 1 Jan 1970"; 173 | test (from_unixfloat 0. = make 1970 1 1 0 0 0) "from_unixfloat 1 Jan 1970"; 174 | test (Utils.Float.equal (to_unixfloat (make 2004 11 13 19 17 9)) 1100373429.) 175 | "to_unixfloat"; 176 | test (equal (from_unixfloat 1100373429.) (make 2004 11 13 19 17 9)) 177 | "from_unixfloat"; 178 | test (from_unixtm (to_unixtm (make 2003 7 16 23 22 21)) = 179 | make 2003 7 16 23 22 21) 180 | "from_unixtm to_unixtm = id"; 181 | 182 | test (Period.to_time (Period.second 30) = Time.Period.second 30) 183 | "Period.to_time second"; 184 | test (Period.to_time (Period.day 6) = Time.Period.second 518400) 185 | "Period.to_time day"; 186 | test (Period.safe_to_time (Period.second 30) = Time.Period.second 30) 187 | "Period.safe_to_time second"; 188 | test (Period.safe_to_time (Period.day 6) = Time.Period.second 518400) 189 | "Period.safe_to_time day"; 190 | Gen_test.test_exn (lazy (Period.to_time (Period.year 1))) "Period.to_time year"; 191 | test (Period.ymds (Period.make 1 2 3 1 2 3) = (1, 2, 3, 3723)) "Period.ymds"; 192 | test 193 | (Period.ymds (Period.make (-1) (-2) (-3) (-1) (-2) (-3)) = (-1,-2,-4,82677)) 194 | "Period.ymds neg"; 195 | () 196 | 197 | let suite = ["test-calendar", `Quick, test] 198 | -------------------------------------------------------------------------------- /tests/test_date.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | open CalendarLib;; 24 | open Date;; 25 | 26 | let test() = 27 | let test x s = Alcotest.(check bool) s true x in 28 | 29 | Gen_test.test_exn (lazy (make (-4713) 1 1)) "make (-4713) 1 1"; 30 | Gen_test.test_exn (lazy (make 3268 1 23)) "make 3268 1 23"; 31 | Gen_test.test_exn (lazy (make 1582 10 5)) "make 1582 10 10"; 32 | test (compare (make 2003 2 29) (make 2003 3 1) = 0) "2003-2-29 = 2003-3-1"; 33 | 34 | test ((make 2018 10 29) > (make 2018 10 28)) "2018-10-29 > 2018-10-28"; 35 | test ((make 2018 10 29) >= (make 2018 10 28)) "2018-10-29 >= 2018-10-28"; 36 | test ((make 2018 10 29) >= (make 2018 10 29)) "2018-10-29 >= 2018-10-29"; 37 | test ((make 2018 10 29) < (make 2018 10 30)) "2018-10-29 < 2018-10-30"; 38 | test ((make 2018 10 29) <= (make 2018 10 30)) "2018-10-29 <= 2018-10-30"; 39 | test ((make 2018 10 29) <= (make 2018 10 29)) "2018-10-29 <= 2018-10-29"; 40 | 41 | let d = make 2003 12 31 in 42 | test (next d `Month = make 2004 1 31) "2003-12-31 + 1 mois"; 43 | test (add d (Period.month 2) = make 2004 3 2) "2003-12-31 + 2 mois"; 44 | test (add (make 2008 12 31) (Period.month 6) = make 2009 7 1) 45 | "2008-12-31 + 6 mois"; 46 | test (rem (make 2008 6 2) (Period.month 12) = make 2007 6 2) 47 | "2008-6-2 - 12 mois"; 48 | test (rem (make 2007 2 30) (Period.month 4) = make 2006 11 2) 49 | "2008-2-30 - 4 mois"; 50 | test (make 2007 (-38) 30 = make 2003 10 30) 51 | "2007-(-38)-30 - 2003 10 30"; 52 | test (rem (make 2007 2 30) (Period.month 40) = make 2003 11 2) 53 | "2008-2-30 - 40 mois"; 54 | let d2 = make (-3000) 1 1 in 55 | test (rem d (sub d d2) = d2) "rem x (sub x y) = y"; 56 | test (Period.ymd (precise_sub (make 2010 10 5) (make 2010 6 2)) = (0, 4, 3)) 57 | "precise_sub 2010-10-5 2010-6-2"; 58 | test (Period.ymd (precise_sub (make 2010 10 5) (make 2010 6 5)) = (0, 4, 0)) 59 | "precise_sub 2010-10-5 2010-6-2"; 60 | test (Period.ymd (precise_sub (make 2010 10 5) (make 2010 6 6)) = (0, 3, 29)) 61 | "precise_sub 2010-10-5 2010-6-6"; 62 | test (Period.ymd (precise_sub (make 2010 10 5) (make 2010 6 4)) = (0, 4, 1)) 63 | "precise_sub 2010-10-5 2010-6-4"; 64 | test (Period.ymd (precise_sub (make 2010 1 1) (make 2000 1 1)) = (10, 0, 0)) 65 | "precise_sub 2010-1-1 2000-1-1"; 66 | test (from_jd 0 = make (-4712) 1 1) "from_jd 0 = 4713 BC-1-1"; 67 | test (to_jd (from_jd 12345) = 12345) "to_jd (from_jd x) = x"; 68 | test (from_mjd 0 = make 1858 11 17) "from_mjd 0 = 1858-11-17"; 69 | test (to_mjd (from_mjd 12345) = 12345) "to_mjd (from_mjd x) = x"; 70 | test (is_leap_day (make 2000 2 24)) "2000-2-24 leap day"; 71 | test (not (is_leap_day (make 2000 2 25))) "2000-2-25 not leap day"; 72 | test (is_gregorian (make 1600 1 1)) "1600-1-1 gregorian"; 73 | test (not (is_gregorian (make 1400 1 1))) "1400-1-1 not gregorian"; 74 | test (is_julian (make 1582 1 1)) "1582-1-1 julian"; 75 | test (not (is_julian (make 1583 1 1))) "1583-1-1 not julian"; 76 | test (int_of_day Mon = 1) "Monday = 1"; 77 | test (int_of_day Sun = 7) "Sunday = 7"; 78 | test (day_of_int 1 = Mon) "1 = Monday"; 79 | test (day_of_int 7 = Sun) "1 = Monday"; 80 | test (int_of_month Jan = 1) "January = 1"; 81 | test (month_of_int 12 = Dec) "12 = December"; 82 | test (not (is_leap_year 1999)) "1999 not leap year"; 83 | test (not (is_leap_year 1800)) "1800 not leap year"; 84 | test (is_leap_year 1996) "1996 leap year"; 85 | test (is_leap_year 1600) "1600 leap year"; 86 | test (same_calendar 1956 1900) "same calendar 1956 1900"; 87 | test (same_calendar 2001 2013) "same calendar 2001 2013"; 88 | test (same_calendar 1998 2009) "same calendar 1998 2009"; 89 | test (same_calendar 2003 2025) "same calendar 2003 2025"; 90 | test (days_in_year 2000 = 366) "days_in_year 2000"; 91 | test (days_in_year 1900 = 365) "days_in_year 1900"; 92 | test (days_in_year ~month:Jan 2000 = 31) "days_in_year Jan 2000"; 93 | test (days_in_year ~month:Feb 2000 = 60) "days_in_year Feb 2000"; 94 | test (days_in_year ~month:Jan 2000 = 31) "days_in_year Jan 2000"; 95 | test (days_in_year ~month:Mar 1900 = 90) "days_in_year Mar 1900"; 96 | test (weeks_in_year 2000 = 52) "weeks_in_year 2000"; 97 | test (weeks_in_year 2020 = 53) "weeks_in_year 2020"; 98 | test (weeks_in_year 1991 = 52) "weeks_in_year 1991"; 99 | test (weeks_in_year 1999 = 52) "weeks_in_year 1999"; 100 | test (days_in_month (make 2000 2 18) = 29) "days_in_month 2000-2-18"; 101 | test (days_in_month (make_year_month 2000 2) = 29) "days_in_month 2000-2"; 102 | (* untypable: *) 103 | (* test (days_in_month ((make_year 2000 :> [ `Year | `Month ] Date.date)) = 29) "days_in_month 2000-2"; *) 104 | test (days_in_year 1900 = 365) "days_in_year 1900"; 105 | test (century 2000 = 20) "century 2000"; 106 | test (century 2001 = 21) "century 2001"; 107 | test (millenium 2000 = 2) "millenium 2000"; 108 | test (millenium 2001 = 3) "millenium 2001"; 109 | test (year (make_year_month 2000 3) = 2000) "year 2000-3"; 110 | test (year (make_year 2000) = 2000) "year 2000"; 111 | test (month (make 2000 4 23) = Apr) "year 2000-4-23"; 112 | test (month (make_year_month 2000 3) = Mar) "year 2000-3"; 113 | (* untypable: *) 114 | (*test (month (make_year 2000) = Mar) "year 2000";*) 115 | test (easter 2003 = make 2003 4 20) "Paques 2003"; 116 | test (Period.nb_days (Period.make 0 0 6) = 6) "Period.nb_days ok"; 117 | test (Period.safe_nb_days (Period.week 3) = 21) "Period.safe_nb_days ok"; 118 | Gen_test.test_exn (lazy (Period.nb_days (Period.make 1 0 0))) "Period.nb_days ko"; 119 | 120 | test (week_first_last 21 2004 = (make 2004 5 17, make 2004 5 23)) 121 | "week_beggining_end"; 122 | 123 | (* January 4th must be in the first week (ISO 8601) *) 124 | (* 2015 is an interesting year in this regard as it tests this rule 125 | to its extreme *) 126 | test (week_first_last 1 2015 = (make 2014 12 29, make 2015 1 4)) 127 | "iso_week_number_startof_2015"; 128 | test (week_first_last 53 2015 = (make 2015 12 28, make 2016 1 3)) 129 | "iso_week_number_endof_2015"; 130 | 131 | test (Period.ymd (Period.make 1 2 3) = (1, 2, 3)) "Period.ymd"; 132 | test (nth_weekday_of_month 2004 Oct Thu 4 = make 2004 10 28) 133 | "nth_weekday_of_month"; 134 | test (nth_weekday_of_month 2006 Mar Fri 3 = make 2006 3 17) 135 | "nth_weekday_of_month"; 136 | test (equal (from_day_of_year 2008 39) (make 2008 2 8)) 137 | "from_day_of_year"; 138 | test (is_valid_date 2008 2 8) "is_valid_date"; 139 | test (not (is_valid_date 2008 2 30)) "not is_valid_date"; 140 | 141 | (* Unix *) 142 | Time_Zone.change Time_Zone.UTC; 143 | test (to_unixfloat (make 1970 1 1) = 0.) "to_unixfloat 1 Jan 1970"; 144 | test (from_unixfloat 0. = make 1970 1 1) "from_unixfloat 0."; 145 | test (to_unixfloat (make 2004 11 13) = 1100304000.) "to_unixfloat"; 146 | test (from_unixfloat 1100304000. = make 2004 11 13) "from_unixfloat"; 147 | test (from_unixtm (to_unixtm (make 2003 7 16)) = make 2003 7 16) 148 | "from_unixtm to_unixtm = id"; 149 | Time_Zone.change (Time_Zone.UTC_Plus (-1)); 150 | test (from_unixfloat 0. = make 1969 12 31) "from_unixfloat 0. (dec-)"; 151 | test (from_unixtm { Unix.tm_sec = 0; tm_min = 0; tm_hour = 0; tm_mday = 1; 152 | tm_mon = 0; tm_year = 70; tm_wday = 4; tm_yday = 0; 153 | tm_isdst = false } = make 1969 12 31) 154 | "from_unixtm (dec-)"; 155 | Time_Zone.change (Time_Zone.UTC_Plus 1); 156 | test (from_unixfloat 1100390390. = make 2004 11 14) "from_unixfloat (dec+)"; 157 | test (from_unixtm { Unix.tm_sec = 0; tm_min = 0; tm_hour = 0; tm_mday = 14; 158 | tm_mon = 10; tm_year = 104; tm_wday = 0; tm_yday = 318; 159 | tm_isdst = false } = make 2004 11 14) 160 | "from_unixtm (dec+)"; 161 | test (from_unixtm (to_unixtm (make 2003 7 16)) = make 2003 7 16) 162 | "from_unixtm to_unixtm = id"; 163 | 164 | (* to_business *) 165 | test (to_business (make 2003 1 1) = (2003, 1, Wed)) "to_business 1"; 166 | test (to_business (make 2003 12 31) = (2004, 1, Wed)) "to_business 2"; 167 | test (to_business (make 2002 12 31) = (2003, 1, Tue)) "to_business 3"; 168 | test (to_business (make 2005 1 1) = (2004, 53, Sat)) "to_business 4"; 169 | test (to_business (make 2004 12 31) = (2004, 53, Fri)) "to_business 5"; 170 | test (to_business (make 2006 1 1) = (2005, 52, Sun)) "to_business 6"; 171 | test (to_business (make 2005 1 17) = (2005, 3, Mon)) "to_business 7"; 172 | test (to_business (make 2006 1 31) = (2006, 5, Tue)) "to_business 8"; 173 | test (to_business (make 2005 1 31) = (2005, 5, Mon)) "to_business 9"; 174 | (* from_business *) 175 | test (from_business 2003 1 Wed = make 2003 1 1) "from_business 1"; 176 | test (from_business 2004 1 Wed = make 2003 12 31) "from_business 2"; 177 | test (from_business 2003 1 Tue = make 2002 12 31) "from_business 3"; 178 | test (from_business 2004 53 Sat = make 2005 1 1) "from_business 4"; 179 | test (from_business 2004 53 Fri = make 2004 12 31) "from_business 5"; 180 | test (from_business 2005 52 Sun = make 2006 1 1) "from_business 6"; 181 | test (from_business 2005 3 Mon = make 2005 1 17) "from_business 7"; 182 | test (from_business 2006 5 Tue = make 2006 1 31) "from_business 8"; 183 | test (from_business 2005 5 Mon = make 2005 1 31) "from_business 9"; 184 | Gen_test.test_exn (lazy (from_business 2005 0 Sun)) "from_business_bad 1"; 185 | Gen_test.test_exn (lazy (from_business 2005 53 Sun)) "from_business_bad 2"; 186 | () 187 | 188 | let suite = ["test_date", `Quick, test] 189 | -------------------------------------------------------------------------------- /tests/test_fcalendar.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*i $Id$ i*) 24 | 25 | open CalendarLib;; 26 | open Fcalendar;; 27 | include Gen_test;; 28 | reset ();; 29 | 30 | let eps = 0.000001;; 31 | 32 | Time_Zone.change Time_Zone.UTC;; 33 | 34 | (* Fcalendar *) 35 | 36 | test_exn (lazy (make (-4712) 1 1 12 0 (-1.))) "-4713-12-31-23-59-59";; 37 | test (make (-4712) 1 1 12 0 0. = make (-4712) 1 0 36 0 0.) "calendar coercion";; 38 | test (from_jd 0. = make (-4712) 1 1 12 0 0.) "from_jd 0 = 4713 BC-1-1";; 39 | test (from_mjd 0. = make 1858 11 17 0 0 0.) "from_mjd 0 = 1858-11-17";; 40 | 41 | Time_Zone.change (Time_Zone.UTC_Plus 5);; 42 | 43 | test (abs_float (to_jd (from_jd 12345.6789) -. 12345.6789) < eps) 44 | "to_jd (from_jd x) = x";; 45 | test (abs_float (to_mjd (from_mjd 12345.6789) -. 12345.6789) < eps) 46 | "to_mjd (from_mjd x) = x";; 47 | test (Period.to_date (Period.hour 60) = Date.Period.day 2) 48 | "period(60h) = period(2d)";; 49 | test (Period.compare (Period.day 2) (Period.hour 60) < 0) "Period.compare <";; 50 | test (Period.compare (Period.day 3) (Period.hour 60) > 0) "Period.compare >";; 51 | test (Period.compare 52 | (Period.add (Period.day 2) (Period.hour 12)) 53 | (Period.hour 60) = 0) "Period.compare =";; 54 | test 55 | (add (make 1 2 3 4 5 6.) (Period.make 9 8 7 6 5 4.5) = 56 | make 10 10 10 10 10 10.5) 57 | "add 1-2-3-4-5-6 9-8-7-6-5-4.5";; 58 | test 59 | (add (make 3 1 1 0 0 0.7) (Period.make 0 0 0 (-25) 0 (-1.3)) = 60 | make 2 12 30 22 59 59.4) 61 | "add 3-1-1-0-0-0.7 0-0-0-(-25)-0-(-1.3)";; 62 | 63 | test 64 | (equal (rem (make 9 8 7 6 5 4.9) (Period.make 1 2 3 4 5 6.4)) 65 | (make 8 6 4 1 59 58.5)) 66 | "rem 9-8-7-6-5-4 1-2-3-4-5-6";; 67 | 68 | test (Period.equal 69 | (sub (make 0 0 7 6 5 4.) (make 0 0 3 54 5 6.)) 70 | (Period.make 0 0 1 23 59 58.)) 71 | "sub 0-0-7-6-5-4 0-0-3-54-5-6";; 72 | 73 | test (Period.equal 74 | (Period.opp (Period.make 0 0 2 3 0 0.)) 75 | (Period.make 0 0 (-2) (-3) 0 0.)) 76 | "period opp";; 77 | 78 | (* Date *) 79 | 80 | let d = make 2003 12 31 12 24 48.;; 81 | test (next d `Month = make 2004 1 31 12 24 48.) "2003-12-31 + 1 mois";; 82 | test (add d (Period.month 2) = make 2004 3 2 12 24 48.) "2003-12-31 + 2 mois";; 83 | let d3 = make 2011 3 24 0 0 0.;; 84 | test (prev d3 `Year = make 2010 3 24 0 0 0.) "2011-3-24 - 1 year";; 85 | let d2 = make (-3000) 1 1 6 12 24.5;; 86 | test (equal (rem d (sub d d2)) d2) "rem x (sub x y) = y";; 87 | test (is_leap_day (make 2000 2 24 0 0 0.)) "2000-2-24 leap day";; 88 | test (not (is_leap_day (make 2000 2 25 0 0 0.))) "2000-2-25 not leap day";; 89 | test (is_gregorian (make 1600 1 1 0 0 0.4)) "1600-1-1 gregorian";; 90 | test (not (is_gregorian (make 1400 1 1 0 0 0.1))) "1400-1-1 not gregorian";; 91 | test (is_julian (make 1582 1 1 0 0 0.1)) "1582-1-1 julian";; 92 | test (not (is_julian (make 1583 1 1 0 0 0.9832))) "1583-1-1 not julian";; 93 | 94 | (* Time *) 95 | 96 | test (let n = Unix.gmtime (Unix.time ()) in 97 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant UTC";; 98 | test (let n = Unix.time () in 99 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 100 | "from_unixfloat invariant UTC";; 101 | 102 | Time_Zone.change (Time_Zone.UTC_Plus 10);; 103 | 104 | test (let n = Unix.gmtime (Unix.time ()) in 105 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant +10";; 106 | test (let n = Unix.time () in 107 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 108 | "from_unixfloat invariant +10";; 109 | 110 | test (equal (add (make 0 0 0 10 0 0.1) (Period.hour 30)) (make 0 0 1 16 0 0.1)) 111 | "add 0-0-0-20-0-0 30h";; 112 | test (equal 113 | (next (make 1999 12 31 23 59 59.43) `Second) 114 | (make 2000 1 1 0 0 0.43)) 115 | "next 1999-31-12-23-59-59 `Second";; 116 | let n = now ();; 117 | test (equal (prev (next n `Minute) `Minute) n) "prev next = id";; 118 | test (equal 119 | (convert 120 | (make 0 0 0 23 0 0.1234) 121 | (Time_Zone.UTC_Plus 2) 122 | (Time_Zone.UTC_Plus 4)) 123 | (make 0 0 1 1 0 0.1234)) "convert";; 124 | 125 | (* Loss of precision *) 126 | test (hour (make 0 0 0 20 0 0.) = 19) "hour";; 127 | test (hour (make 0 0 0 20 0 0.2) = 20) "hour";; 128 | 129 | test (minute (make 0 0 0 20 10 0.2) = 10) "minute";; 130 | 131 | (* Loss of precision *) 132 | test (Utils.Float.equal (second (make 0 0 0 20 10 5.123)) 5.123004) "second";; 133 | 134 | test (is_pm (make 0 0 0 10 0 0.1)) "is_pm 10-0-0";; 135 | test (is_pm (make 0 0 0 34 0 0.)) "is_pm 34-0-0";; 136 | test (not (is_pm (make 0 0 0 (- 10) 0 0.))) "not (is_pm (- 10) 0 0)";; 137 | test (is_am (make 0 0 0 20 0 0.)) "is_am 20-0-0";; 138 | test (is_am (make 0 0 0 (- 34) 0 0.)) "is_am (- 34) 0 0";; 139 | test (not (is_am (make 0 0 0 34 0 0.))) "not (is_pm 34 0 0)";; 140 | 141 | Time_Zone.change Time_Zone.UTC;; 142 | 143 | test (let n = Unix.gmtime (Unix.time ()) in 144 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant UTC2";; 145 | test (let n = Unix.time () in 146 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 147 | "from_unixfloat invariant UTC2";; 148 | 149 | test (to_unixfloat (make 1970 1 1 0 0 0.) = 0.) "to_unixfloat 1 Jan 1970";; 150 | test (from_unixfloat 0. = make 1970 1 1 0 0 0.) "from_unixfloat 1 Jan 1970";; 151 | test (Utils.Float.equal (to_unixfloat (make 2004 11 13 19 17 9.)) 1100373429.) 152 | "to_unixfloat";; 153 | test (equal (from_unixfloat 1100373429.) (make 2004 11 13 19 17 9.)) 154 | "from_unixfloat";; 155 | 156 | (* Loss of precision *) 157 | test (equal 158 | (from_unixtm (to_unixtm (make 2003 7 16 23 22 21.))) 159 | (make 2003 7 16 23 22 20.)) 160 | "from_unixtm to_unixtm = id";; 161 | 162 | test (Period.to_time (Period.second 30.12) = Time.Period.second 30.12) 163 | "Period.to_time second";; 164 | test (Period.to_time (Period.day 6) = Time.Period.second 518400.) 165 | "Period.to_time day";; 166 | test (Period.safe_to_time (Period.second 30.12) = Time.Period.second 30.12) 167 | "Period.safe_to_time second";; 168 | test (Period.safe_to_time (Period.day 6) = Time.Period.second 518400.) 169 | "Period.safe_to_time day";; 170 | test_exn (lazy (Period.to_time (Period.year 1))) "Period.to_time year";; 171 | test (Period.ymds (Period.make 1 2 3 1 2 3.1) = (1, 2, 3, 3723.1)) 172 | "Period.ymds";; 173 | test 174 | (Period.ymds (Period.make (-1) (-2) (-3) (-1) (-2) (-3.)) = (-1,-2,-4,82677.)) 175 | "Period.ymds neg";; 176 | 177 | let ok = nb_ok ();; 178 | let bug = nb_bug ();; 179 | Printf.printf "tests ok : %d; tests ko : %d\n" ok bug;; 180 | flush stdout;; 181 | -------------------------------------------------------------------------------- /tests/test_fpcalendar.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*i $Id$ i*) 24 | 25 | open CalendarLib;; 26 | open Fcalendar.Precise;; 27 | 28 | 29 | let test () = 30 | let test x s = Alcotest.(check bool) s true x in 31 | 32 | let eps = 0.000001 in 33 | 34 | Time_Zone.change Time_Zone.UTC; 35 | 36 | (* Fcalendar *) 37 | 38 | Gen_test.test_exn (lazy (make (-4712) 1 1 12 0 (-1.))) "-4713-12-31-23-59-59"; 39 | test (make (-4712) 1 1 12 0 0. = make (-4712) 1 0 36 0 0.) "calendar coercion"; 40 | test (from_jd 0. = make (-4712) 1 1 12 0 0.) "from_jd 0 = 4713 BC-1-1"; 41 | test (from_mjd 0. = make 1858 11 17 0 0 0.) "from_mjd 0 = 1858-11-17"; 42 | 43 | Time_Zone.change (Time_Zone.UTC_Plus 5); 44 | 45 | test (abs_float (to_jd (from_jd 12345.6789) -. 12345.6789) < eps) 46 | "to_jd (from_jd x) = x"; 47 | test (abs_float (to_mjd (from_mjd 12345.6789) -. 12345.6789) < eps) 48 | "to_mjd (from_mjd x) = x"; 49 | test (Period.to_date (Period.hour 60) = Date.Period.day 2) 50 | "period(60h) = period(2d)"; 51 | test (Period.compare (Period.day 2) (Period.hour 60) < 0) "Period.compare <"; 52 | test (Period.compare (Period.day 3) (Period.hour 60) > 0) "Period.compare >"; 53 | test (Period.compare 54 | (Period.add (Period.day 2) (Period.hour 12)) 55 | (Period.hour 60) = 0) "Period.compare ="; 56 | test 57 | (add (make 1 2 3 4 5 6.) (Period.make 9 8 7 6 5 4.5) = 58 | make 10 10 10 10 10 10.5) 59 | "add 1-2-3-4-5-6 9-8-7-6-5-4.5"; 60 | test 61 | (add (make 3 1 1 0 0 0.7) (Period.make 0 0 0 (-25) 0 (-1.3)) = 62 | make 2 12 30 22 59 59.4) 63 | "add 3-1-1-0-0-0.7 0-0-0-(-25)-0-(-1.3)"; 64 | 65 | test 66 | (equal (rem (make 9 8 7 6 5 4.9) (Period.make 1 2 3 4 5 6.4)) 67 | (make 8 6 4 1 59 58.5)) 68 | "rem 9-8-7-6-5-4 1-2-3-4-5-6"; 69 | 70 | test (Period.equal 71 | (sub (make 0 0 7 6 5 4.) (make 0 0 3 54 5 6.)) 72 | (Period.make 0 0 1 23 59 58.)) 73 | "sub 0-0-7-6-5-4 0-0-3-54-5-6"; 74 | 75 | test (Period.equal 76 | (Period.opp (Period.make 0 0 2 3 0 0.)) 77 | (Period.make 0 0 (-2) (-3) 0 0.)) 78 | "period opp"; 79 | 80 | (* Date *) 81 | 82 | let d = make 2003 12 31 12 24 48. in 83 | test (next d `Month = make 2004 1 31 12 24 48.) "2003-12-31 + 1 mois"; 84 | test (add d (Period.month 2) = make 2004 3 2 12 24 48.) "2003-12-31 + 2 mois"; 85 | let d3 = make 2011 3 24 0 0 0. in 86 | test (prev d3 `Year = make 2010 3 24 0 0 0.) "2011-3-24 - 1 year"; 87 | let d2 = make (-3000) 1 1 6 12 24.5 in 88 | test (equal (rem d (sub d d2)) d2) "rem x (sub x y) = y"; 89 | test (is_leap_day (make 2000 2 24 0 0 0.)) "2000-2-24 leap day"; 90 | test (not (is_leap_day (make 2000 2 25 0 0 0.))) "2000-2-25 not leap day"; 91 | test (is_gregorian (make 1600 1 1 0 0 0.4)) "1600-1-1 gregorian"; 92 | test (not (is_gregorian (make 1400 1 1 0 0 0.1))) "1400-1-1 not gregorian"; 93 | test (is_julian (make 1582 1 1 0 0 0.1)) "1582-1-1 julian"; 94 | test (not (is_julian (make 1583 1 1 0 0 0.9832))) "1583-1-1 not julian"; 95 | 96 | (* Time *) 97 | 98 | test (let n = Unix.gmtime (Unix.time ()) in 99 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant UTC"; 100 | test (let n = Unix.time () in 101 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 102 | "from_unixfloat invariant UTC"; 103 | 104 | Time_Zone.change (Time_Zone.UTC_Plus 10); 105 | 106 | test (let n = Unix.gmtime (Unix.time ()) in 107 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant +10"; 108 | test (let n = Unix.time () in 109 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 110 | "from_unixfloat invariant +10"; 111 | 112 | test (equal (add (make 0 0 0 10 0 0.1) (Period.hour 30)) (make 0 0 1 16 0 0.1)) 113 | "add 0-0-0-20-0-0 30h"; 114 | test (equal 115 | (next (make 1999 12 31 23 59 59.43) `Second) 116 | (make 2000 1 1 0 0 0.43)) 117 | "next 1999-31-12-23-59-59 `Second"; 118 | let n = now () in 119 | test (equal (prev (next n `Minute) `Minute) n) "prev next = id"; 120 | test (equal 121 | (convert 122 | (make 0 0 0 23 0 0.1234) 123 | (Time_Zone.UTC_Plus 2) 124 | (Time_Zone.UTC_Plus 4)) 125 | (make 0 0 1 1 0 0.1234)) "convert"; 126 | 127 | test (hour (make 0 0 0 20 0 0.) = 20) "hour"; 128 | test (minute (make 0 0 0 20 10 0.2) = 10) "minute"; 129 | test (Utils.Float.equal (second (make 0 0 0 20 10 5.123)) 5.123) "second"; 130 | 131 | test (is_pm (make 0 0 0 10 0 0.1)) "is_pm 10-0-0"; 132 | test (is_pm (make 0 0 0 34 0 0.)) "is_pm 34-0-0"; 133 | test (not (is_pm (make 0 0 0 (- 10) 0 0.))) "not (is_pm (- 10) 0 0)"; 134 | test (is_am (make 0 0 0 20 0 0.)) "is_am 20-0-0"; 135 | test (is_am (make 0 0 0 (- 34) 0 0.)) "is_am (- 34) 0 0"; 136 | test (not (is_am (make 0 0 0 34 0 0.))) "not (is_pm 34 0 0)"; 137 | 138 | Time_Zone.change Time_Zone.UTC; 139 | 140 | test (let n = Unix.gmtime (Unix.time ()) in 141 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant UTC2"; 142 | test (let n = Unix.time () in 143 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 144 | "from_unixfloat invariant UTC2"; 145 | 146 | test (to_unixfloat (make 1970 1 1 0 0 0.) = 0.) "to_unixfloat 1 Jan 1970"; 147 | test (from_unixfloat 0. = make 1970 1 1 0 0 0.) "from_unixfloat 1 Jan 1970"; 148 | test (floor (to_unixfloat (make 2004 11 13 19 17 10.)) = 1100373429.) 149 | "to_unixfloat"; 150 | test (equal (from_unixfloat 1100373429.) (make 2004 11 13 19 17 09.)) 151 | "from_unixfloat"; 152 | 153 | test (equal 154 | (from_unixtm (to_unixtm (make 2003 7 16 23 22 21.))) 155 | (make 2003 7 16 23 22 21.)) 156 | "from_unixtm to_unixtm = id"; 157 | 158 | test (Period.safe_to_time (Period.second 30.12) = Time.Period.second 30.12) 159 | "Period.safe_to_time second"; 160 | test (Period.safe_to_time (Period.day 6) = Time.Period.second 518400.) 161 | "Period.safe_to_time day"; 162 | Gen_test.test_exn (lazy (Period.to_time (Period.year 1))) "Period.to_time year"; 163 | test (Period.ymds (Period.make 1 2 3 1 2 3.1) = (1, 2, 3, 3723.1)) 164 | "Period.ymds"; 165 | test 166 | (Period.ymds (Period.make (-1) (-2) (-3) (-1) (-2) (-3.)) = (-1,-2,-4,82677.)) 167 | "Period.ymds neg"; 168 | () 169 | 170 | let suite = ["fpcalendar", `Quick, test] 171 | -------------------------------------------------------------------------------- /tests/test_ftime.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*i $Id$ i*) 24 | 25 | open CalendarLib 26 | open Ftime;; 27 | 28 | let test x s = Alcotest.(check bool) s true x 29 | let test_f x y s = Alcotest.(check @@ testable Fmt.float Utils.Float.equal) s x y 30 | 31 | let test1 () = 32 | Time_Zone.change (Time_Zone.UTC_Plus 10); 33 | 34 | (* Some [=] are used which should be replaced by [equal]. *) 35 | 36 | test (make 30 60 80.5 = make 31 1 20.5) "30-60-80.5 = 31-1-20.5"; 37 | test (normalize (make 22 0 0.1) = (make 22 0 0.1, 0)) "normalize 22-0-0.1"; 38 | test (normalize (make 73 0 0.) = (make 1 0 0., 3)) "normalize 73-0-0"; 39 | test (normalize (make (-73) 0 0.) = (make 23 0 0., -4)) "normalize (-73)-0-0"; 40 | test (add (make 20 0 0.2) (Period.minute 70) = make 21 10 0.2) 41 | "add 20-0-0.2 70mn"; 42 | test (next (make 20 3 31.) `Minute = make 20 4 31.) "next 20-3-31 `Minute"; 43 | test (prev (make 20 3 31.34) `Second = make 20 3 30.34) 44 | "prev 20-3-31.34 `Second"; 45 | test (Period.equal (sub (make 6 5 4.) (make 4 5 6.1)) (Period.make 1 59 57.9)) 46 | "sub 6-5-4. 4-5-6.1"; 47 | test (convert (make 20 0 0.123) (Time_Zone.UTC_Plus 2) (Time_Zone.UTC_Plus 4) = 48 | make 22 0 0.123) "convert"; 49 | test (to_gmt (make 20 0 0.) = make 10 0 0.) "to_gmt"; 50 | test (from_gmt (make 20 0 0.) = make 30 0 0.) "from_gmt"; 51 | test (midnight () = make 0 0 0.) "midnight"; 52 | test (midday () = make 12 0 0.) "midday"; 53 | test (hour (make 20 0 59.99) = 20) "hour"; 54 | test (minute (make 20 10 0.) = 10) "minute"; 55 | test (second (make 20 10 5.) = 5.) "second"; 56 | () 57 | 58 | let test2() = 59 | Time_Zone.change (Time_Zone.UTC_Plus 10); 60 | Utils.Float.set_precision 1e-6; 61 | let one_two_three = make 1 2 3. in 62 | test (to_seconds one_two_three = 3723.) "to_seconds"; 63 | test (to_minutes one_two_three = 62.05) "to_minutes"; 64 | test_f (to_hours (make 1 3 0.4)) 1.050111 "to_hours"; 65 | test (equal (from_seconds 3723.2) (from_minutes 62.053333333)) 66 | "from_seconds; from_minutes"; 67 | test (from_hours 1.05 = make 1 3 0.) "from_hours"; 68 | test (is_pm (midnight ())) "is_pm midnight"; 69 | test (is_pm (make 10 0 0.)) "is_pm 10-0-0"; 70 | test (is_pm (make 34 0 0.)) "is_pm 34-0-0"; 71 | test (not (is_pm (make (- 10) 0 0.))) "not (is_pm (- 10) 0 0)"; 72 | test (is_am (midday ())) "is_am midday"; 73 | test (is_am (make 20 0 0.)) "is_am 20-0-0"; 74 | test (is_am (make (- 34) 0 0.)) "is_am (- 34) 0 0"; 75 | test (not (is_am (make 34 0 0.))) "not (is_pm 34 0 0)"; 76 | () 77 | 78 | let test3() = 79 | Time_Zone.change (Time_Zone.UTC_Plus 10); 80 | Utils.Float.set_precision 1e-6; 81 | let one_two_three = Period.make 1 2 3. in 82 | test_f (Period.to_seconds one_two_three) 3723. 83 | "Period.to_seconds"; 84 | test_f (Period.to_minutes one_two_three) 62.05 85 | "Period.to_minutes"; 86 | test_f (Period.to_hours (Period.make 1 3 0.1)) 1.050028 87 | "Period.to_hours"; 88 | () 89 | 90 | let suite = [ 91 | "ftime1", `Quick, test1; 92 | "ftime2", `Quick, test2; 93 | "ftime3", `Quick, test3; 94 | ] 95 | -------------------------------------------------------------------------------- /tests/test_pcalendar.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*i $Id$ i*) 24 | 25 | open CalendarLib;; 26 | open Calendar.Precise;; 27 | 28 | let test() = 29 | let test x s = Alcotest.(check bool) s true x in 30 | 31 | let eps = 0.000001 in 32 | 33 | Time_Zone.change Time_Zone.UTC; 34 | 35 | (* Calendar *) 36 | 37 | Gen_test.test_exn (lazy (make (-4712) 1 1 12 0 (-1))) "-4713-12-31-23-59-59"; 38 | test (make (-4712) 1 1 12 0 0 = make (-4712) 1 0 36 0 0) "calendar coercion"; 39 | test (from_jd 0. = make (-4712) 1 1 12 0 0) "from_jd 0 = 4713 BC-1-1"; 40 | test (from_mjd 0. = make 1858 11 17 0 0 0) "from_mjd 0 = 1858-11-17"; 41 | 42 | Time_Zone.change (Time_Zone.UTC_Plus 5); 43 | 44 | test (abs_float (to_jd (from_jd 12345.6789) -. 12345.6789) < eps) 45 | "to_jd (from_jd x) = x"; 46 | test (abs_float (to_mjd (from_mjd 12345.6789) -. 12345.6789) < eps) 47 | "to_mjd (from_mjd x) = x"; 48 | test (Period.to_date (Period.hour 60) = Date.Period.day 2) 49 | "period(60h) = period(2d)"; 50 | test (Period.compare (Period.day 2) (Period.hour 60) < 0) "Period.compare <"; 51 | test (Period.compare (Period.day 3) (Period.hour 60) > 0) "Period.compare >"; 52 | test (Period.compare 53 | (Period.add (Period.day 2) (Period.hour 12)) 54 | (Period.hour 60) = 0) "Period.compare ="; 55 | 56 | test 57 | (add (make 1 2 3 4 5 6) (Period.make 9 8 7 6 5 4) = make 10 10 10 10 10 10) 58 | "add 1-2-3-4-5-6 9-8-7-6-5-4"; 59 | test 60 | (add (make 3 1 1 0 0 0) (Period.make 0 0 0 (-25) 0 (-1)) = 61 | make 2 12 30 22 59 59) 62 | "add 3-1-1-0-0-0 0-0-0-(-25)-0-(-1)"; 63 | 64 | test 65 | (equal (rem (make 9 8 7 6 5 4) (Period.make 1 2 3 4 5 6)) 66 | (make 8 6 4 1 59 58)) 67 | "rem 9-8-7-6-5-4 1-2-3-4-5-6"; 68 | test (sub (make 0 0 7 6 5 4) (make 0 0 3 54 5 6) = Period.make 0 0 1 23 59 58) 69 | "sub 0-0-7-6-5-4 0-0-3-54-5-6"; 70 | 71 | test (Period.equal 72 | (Period.opp (Period.make 0 0 2 3 0 0)) 73 | (Period.make 0 0 (-2) (-3) 0 0)) 74 | "period opp"; 75 | 76 | (* Date *) 77 | 78 | let d = make 2003 12 31 12 24 48 in 79 | test (next d `Month = make 2004 1 31 12 24 48) "2003-12-31 + 1 mois"; 80 | test (add d (Period.month 2) = make 2004 3 2 12 24 48) "2003-12-31 + 2 mois"; 81 | let d3 = make 2011 3 24 0 0 0 in 82 | test (prev d3 `Year = make 2010 3 24 0 0 0) "2011-3-24 - 1 year"; 83 | let d2 = make (-3000) 1 1 6 12 24 in 84 | test (equal (rem d (sub d d2)) d2) "rem x (sub x y) = y"; 85 | test (is_leap_day (make 2000 2 24 0 0 0)) "2000-2-24 leap day"; 86 | test (not (is_leap_day (make 2000 2 25 0 0 0))) "2000-2-25 not leap day"; 87 | test (is_gregorian (make 1600 1 1 0 0 0)) "1600-1-1 gregorian"; 88 | test (not (is_gregorian (make 1400 1 1 0 0 0))) "1400-1-1 not gregorian"; 89 | test (is_julian (make 1582 1 1 0 0 0)) "1582-1-1 julian"; 90 | test (not (is_julian (make 1583 1 1 0 0 0))) "1583-1-1 not julian"; 91 | 92 | (* Time *) 93 | 94 | test (let n = Unix.gmtime (Unix.time ()) in 95 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant UTC"; 96 | test (let n = Unix.time () in 97 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 98 | "from_unixfloat invariant UTC"; 99 | 100 | Time_Zone.change (Time_Zone.UTC_Plus 10); 101 | 102 | test (let n = Unix.gmtime (Unix.time ()) in 103 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant +10"; 104 | test (let n = Unix.time () in 105 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 106 | "from_unixfloat invariant +10"; 107 | 108 | test (equal (add (make 0 0 0 10 0 0) (Period.hour 30)) (make 0 0 1 16 0 0)) 109 | "add 0-0-0-20-0-0 30h"; 110 | test (equal (next (make 1999 12 31 23 59 59) `Second) (make 2000 1 1 0 0 0)) 111 | "next 1999-31-12-23-59-59 `Second"; 112 | let n = now () in 113 | test (equal (prev (next n `Minute) `Minute) n) "prev next = id"; 114 | 115 | test (equal 116 | (convert 117 | (make 0 0 0 23 0 0) 118 | (Time_Zone.UTC_Plus 2) 119 | (Time_Zone.UTC_Plus 4)) 120 | (make 0 0 1 1 0 0)) "convert"; 121 | test (hour (make 0 0 0 20 0 0) = 20) "hour"; 122 | test (minute (make 0 0 0 20 10 0) = 10) "minute"; 123 | test (second (make 0 0 0 20 10 5) = 5) "second"; 124 | test (is_pm (make 0 0 0 10 0 0)) "is_pm 10-0-0"; 125 | test (is_pm (make 0 0 0 34 0 0)) "is_pm 34-0-0"; 126 | test (not (is_pm (make 0 0 0 (- 10) 0 0))) "not (is_pm (- 10) 0 0)"; 127 | test (is_am (make 0 0 0 20 0 0)) "is_am 20-0-0"; 128 | test (is_am (make 0 0 0 (- 34) 0 0)) "is_am (- 34) 0 0"; 129 | test (not (is_am (make 0 0 0 34 0 0))) "not (is_pm 34 0 0)"; 130 | 131 | Time_Zone.change Time_Zone.UTC; 132 | 133 | test (let n = Unix.gmtime (Unix.time ()) in 134 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant UTC2"; 135 | test (let n = Unix.time () in 136 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 137 | "from_unixfloat invariant UTC2"; 138 | 139 | test (to_unixfloat (make 1970 1 1 0 0 0) = 0.) "to_unixfloat 1 Jan 1970"; 140 | test (from_unixfloat 0. = make 1970 1 1 0 0 0) "from_unixfloat 1 Jan 1970"; 141 | test (Utils.Float.equal (to_unixfloat (make 2004 11 13 19 17 9)) 1100373429.) 142 | "to_unixfloat"; 143 | test (equal (from_unixfloat 1100373429.) (make 2004 11 13 19 17 9)) 144 | "from_unixfloat"; 145 | test (from_unixtm (to_unixtm (make 2003 7 16 23 22 21)) = 146 | make 2003 7 16 23 22 21) 147 | "from_unixtm to_unixtm = id"; 148 | 149 | test (Period.to_time (Period.second 30) = Time.Period.second 30) 150 | "Period.to_time second"; 151 | test (Period.safe_to_time (Period.second 30) = Time.Period.second 30) 152 | "Period.safe_to_time second"; 153 | test (Period.to_time (Period.day 6) = Time.Period.second 518400) 154 | "Period.to_time day"; 155 | test (Period.safe_to_time (Period.day 6) = Time.Period.second 518400) 156 | "Period.safe_to_time day"; 157 | Gen_test.test_exn (lazy (Period.to_time (Period.year 1))) "Period.to_time year"; 158 | test (Period.ymds (Period.make 1 2 3 1 2 3) = (1, 2, 3, 3723)) "Period.ymds"; 159 | test 160 | (Period.ymds (Period.make (-1) (-2) (-3) (-1) (-2) (-3)) = (-1,-2,-4,82677)) 161 | "Period.ymds neg"; 162 | () 163 | 164 | let suite = ["pcalendar", `Quick, test] 165 | -------------------------------------------------------------------------------- /tests/test_printer.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | open CalendarLib;; 24 | open Printer.Date;; 25 | 26 | let test () = 27 | let test x s = Alcotest.(check bool) s true x in 28 | let d = Date.make 2003 1 6 in 29 | test (sprint "%D" d = "01/06/03") "sprint %D"; 30 | test (sprint "the date is %B, the %-dth" d = "the date is January, the 6th") 31 | "sprint (long sentence)"; 32 | test (sprint "%^B, the %0dth" d = "JANUARY, the 06th") "sprint padding"; 33 | test (sprint "%j" d = "006") "sprint %j"; 34 | test (sprint "%-j" d = "6") "sprint %j"; 35 | test (sprint "%_j" d = " 6") "sprint %j"; 36 | test (sprint "%j" (Date.make 2003 1 10) = "010") "sprint %j"; 37 | test (sprint "%-j" (Date.make 2003 1 10) = "10") "sprint %j"; 38 | test (sprint "%_j" (Date.make 2003 1 10) = " 10") "sprint %j"; 39 | test (sprint "%C" (Date.make 2008 12 5) = "21") "sprint %C"; 40 | test (from_string "2003-01-06" = Date.make 2003 1 6) "from_string"; 41 | test (from_fstring "%y-%m-%d" "03-01-06" = Date.make 1903 1 6) "from_fstring"; 42 | test 43 | (from_fstring "%Y%t%m%t%d" "1903\t01\t06" = Date.make 1903 1 6) 44 | "from_fstring %t"; 45 | test 46 | (from_fstring "%Y-%B-%d" "2007-May-14" = Date.make 2007 5 14) 47 | "from_fstring %B"; 48 | 49 | test 50 | (from_fstring "%Y-%b-%d" "2007-Jan-14" = Date.make 2007 1 14) 51 | "from_fstring %B"; 52 | 53 | test (from_fstring "%Y %V %w" "2004 01 1" = Date.make 2003 12 29) 54 | "from_fstring %Y %V %w"; 55 | test (from_fstring "%V %Y %w" "52 1999 7" = Date.make 2000 1 2) 56 | "from_fstring %V %Y %w"; 57 | Gen_test.test_exn (lazy (from_fstring "%Y %w" "1999 7")) "from_fstring_exn"; 58 | test (from_fstring "%Y%j" "1903001" = Date.make 1903 1 1) "from_fstring %Y%j"; 59 | test (from_fstring "%j%Y" "0011903" = Date.make 1903 1 1) "from_fstring %j%Y"; 60 | Gen_test.test_exn (lazy (from_fstring "%j" "001")) "from_fstring_exn 2"; 61 | 62 | let open Printer.Time in 63 | test (to_string (Time.make 12 1 4) = "12:01:04") "to_string (on TimePrinter)"; 64 | test (sprint "%I" (Time.make 36 4 3) = "12") "sprint %I (on TimePrinter)"; 65 | test (sprint "%r" (Time.make 24 4 3) = "12:04:03 AM") 66 | "sprint %r (on TimePrinter)"; 67 | test (sprint "%R %z" (Time.make 12 24 5) = "12:24 +0000") "sprint %R %z"; 68 | test 69 | (Time_Zone.on (fun () -> sprint "%R %z" (Time.make 12 24 5)) 70 | (Time_Zone.UTC_Plus (-3)) () = "12:24 -0300") 71 | "sprint %R %z neg"; 72 | test (sprint "%R %S %:z" (Time.make 23 47 55) = "23:47 55 +00:00") 73 | "sprint %R %S %:z"; 74 | test 75 | (Time_Zone.on (fun () -> sprint "%R %S %::z" (Time.make 7 47 55)) 76 | (Time_Zone.UTC_Plus 3) () = "07:47 55 +03:00:00") 77 | "sprint %R %S %::z"; 78 | Gen_test.test_exn (lazy (sprint "%R %:a" (Time.make 23 47 55))) "sprint %R %:a"; 79 | Gen_test.test_exn (lazy (sprint "%::::z %R" (Time.make 23 47 55))) "sprint %::::z %R"; 80 | 81 | test (from_fstring "%R %S %z" "10:47 55 -0300" = Time.make 13 47 55) 82 | "from_fstring %R %S %z"; 83 | test (from_fstring "%R %S %:z" "10:47 55 -13:00" = Time.make 23 47 55) 84 | "from_fstring %R %S %:z"; 85 | Gen_test.test_exn (lazy (from_fstring "%R %S %:z" "10:47 55 -0300")) 86 | "from_fstring %R %S %:z bug1"; 87 | Gen_test.test_exn (lazy (from_fstring "%R %S %:z" "10:47 55 -03:00:00")) 88 | "from_fstring %R %S %:z bug2"; 89 | test (from_fstring "%R %S %::z" "10:47 55 +03:00:00" = Time.make 7 47 55) 90 | "from_fstring %R %S %::z"; 91 | test (from_fstring "%R %S %:::z" "10:47 55 -03" = Time.make 13 47 55) 92 | "from_fstring %R %S %:::z"; 93 | Gen_test.test_exn (lazy (from_fstring "%R %S %::::z" "10:47 55 -0300")) 94 | "from_fstring %R %S %::::z"; 95 | test (from_fstring "%r" "10:47:25 AM" = Time.make 10 47 25) 96 | "from_fstring AM (on TimePrinter)"; 97 | test (from_fstring "%r" "10:47:25 PM" = Time.make 22 47 25) 98 | "from_fstring PM (on TimePrinter)"; 99 | Gen_test.test_exn (lazy (from_fstring "%p %I:%M:%S" "TM 5:26:17")) 100 | "from_fstring error on %p (on TimePrinter)"; 101 | 102 | let open Printer.Calendar in 103 | test (sprint "%c" (Calendar.make 2003 1 6 12 1 4) = "Mon Jan 06 12:01:04 2003") 104 | "sprint %c"; 105 | test (to_string (Calendar.make 2004 10 25 24 0 1) = "2004-10-26 00:00:01") 106 | "to_string (on CalendarPrinter)"; 107 | test 108 | (from_fstring "%c" "Mon May 14 10:30:00 2007" 109 | = Calendar.make 2007 5 14 10 30 0) 110 | "from_fstring (on CalendarPrinter)"; 111 | test (sprint "%s" (Calendar.make 1971 1 1 0 0 0) = "31536000") 112 | "sprint %s"; 113 | 114 | test (Utils.Float.equal 115 | (Ftime.second 116 | (Printer.Ftime.from_fstring 117 | "%Y-%m-%dT%H:%M:%S%:z" "2014-03-19T15:51:25.05-07:00")) 118 | 25.05) 119 | "from_string with floating seconds"; 120 | () 121 | 122 | let suite = ["printer", `Quick, test] 123 | -------------------------------------------------------------------------------- /tests/test_time.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*i $Id$ i*) 24 | 25 | open CalendarLib 26 | open Time;; 27 | 28 | let test () = 29 | let test x s = Alcotest.(check bool) s true x in 30 | Time_Zone.change (Time_Zone.UTC_Plus 10); 31 | 32 | test (make 30 60 80 = make 31 1 20) "30-60-80 = 31-1-20"; 33 | test (normalize (make 22 0 0) = (make 22 0 0, 0)) "normalize 22-0-0"; 34 | test (normalize (make 73 0 0) = (make 1 0 0, 3)) "normalize 73-0-0"; 35 | test (normalize (make (-73) 0 0) = (make 23 0 0, -4)) "normalize (-73)-0-0"; 36 | test (add (make 20 0 0) (Period.minute 70) = make 21 10 0) "add 20-0-0 70mn"; 37 | test (next (make 20 3 31) `Minute = make 20 4 31) "next 20-3-31 `Minute"; 38 | test (prev (make 20 3 31) `Second = make 20 3 30) "prev 20-3-31 `Second"; 39 | test (sub (make 6 5 4) (make 4 5 6) = Period.make 1 59 58) "sub 6-5-4 4-5-6"; 40 | test (convert (make 20 0 0) (Time_Zone.UTC_Plus 2) (Time_Zone.UTC_Plus 4) = 41 | make 22 0 0) "convert"; 42 | test (to_gmt (make 20 0 0) = make 10 0 0) "to_gmt"; 43 | test (from_gmt (make 20 0 0) = make 30 0 0) "from_gmt"; 44 | test (midnight () = make 0 0 0) "midnight"; 45 | test (midday () = make 12 0 0) "midday"; 46 | test (hour (make 20 0 0) = 20) "hour"; 47 | test (minute (make 20 10 0) = 10) "minute"; 48 | test (second (make 20 10 5) = 5) "second"; 49 | 50 | let one_two_three = make 1 2 3 in 51 | test (to_seconds one_two_three = 3723) "to_seconds"; 52 | test (Utils.Float.equal (to_minutes one_two_three) 62.05) "to_minutes"; 53 | test (to_hours (make 1 3 0) = 1.05) "to_hours"; 54 | test (from_seconds 3723 = from_minutes 62.05) "from_seconds; from_minutes"; 55 | test (from_hours 1.05 = make 1 3 0) "from_hours"; 56 | test (is_pm (midnight ())) "is_pm midnight"; 57 | test (is_pm (make 10 0 0)) "is_pm 10-0-0"; 58 | test (is_pm (make 34 0 0)) "is_pm 34-0-0"; 59 | test (not (is_pm (make (- 10) 0 0))) "not (is_pm (- 10) 0 0)"; 60 | test (is_am (midday ())) "is_am midday"; 61 | test (is_am (make 20 0 0)) "is_am 20-0-0"; 62 | test (is_am (make (- 34) 0 0)) "is_am (- 34) 0 0"; 63 | test (not (is_am (make 34 0 0))) "not (is_pm 34 0 0)"; 64 | 65 | let one_two_three = Period.make 1 2 3 in 66 | test (Period.to_seconds one_two_three = 3723) "Period.to_seconds"; 67 | test (Utils.Float.equal (Period.to_minutes one_two_three) 62.05) 68 | "Period.to_minutes"; 69 | test (Utils.Float.equal (Period.to_hours (Period.make 1 3 0)) 1.05) 70 | "Period.to_hours"; 71 | () 72 | 73 | 74 | let suite = [ 75 | "time", `Quick, test; 76 | ] 77 | -------------------------------------------------------------------------------- /tests/test_timezone.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (*i $Id$ i*) 24 | 25 | open CalendarLib 26 | open Time_Zone;; 27 | 28 | let tz = Alcotest.testable (Fmt.always "timezone") (=) ;; 29 | 30 | let test () = 31 | change UTC; 32 | Alcotest.(check tz) "current () = UTC" UTC (current ()); 33 | change Local; 34 | Alcotest.(check tz) "current () = Local" Local (current ()); 35 | Alcotest.(check int) "gap UTC (UTC_Plus (-5)) = -5" ~-5 (gap UTC (UTC_Plus ~-5)); 36 | let g6 = UTC_Plus 6 in 37 | Alcotest.(check int) 38 | "gap g6 Local = gap g6 UTC + gap UTC Local" 39 | (gap g6 Local) (gap g6 UTC + gap UTC Local); 40 | Gen_test.test_exn (lazy (change (UTC_Plus 13))) "change 13"; 41 | Gen_test.test_exn (lazy (change (UTC_Plus (-15)))) "change (-15)"; 42 | change (UTC_Plus 4); 43 | Alcotest.(check int) "from_gmt () = 4" 4 (from_gmt ()) ; 44 | Alcotest.(check int) "to_gmt () = -4" ~-4 (to_gmt ()); 45 | () 46 | 47 | let suite = ["timezone", `Quick, test] 48 | -------------------------------------------------------------------------------- /utils/example.ml.3: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Version for OCaml 3.* *) 24 | 25 | (** Add a tag @example *) 26 | class example = object (self) 27 | inherit Odoc_html.html as super 28 | 29 | method html_of_example txt = 30 | let buf = Buffer.create 97 in 31 | self#html_of_text buf txt; 32 | Format.sprintf "%s
\n" (Buffer.contents buf); 33 | 34 | method html_of_examples = function 35 | | [] -> "" 36 | | [ txt ] -> Format.sprintf "Example: %s" (self#html_of_example txt) 37 | | examples -> 38 | let s = Format.sprintf "Examples:
    " in 39 | let s = 40 | List.fold_left 41 | (fun acc txt -> 42 | Format.sprintf "%s
  • %s
    • " 43 | acc 44 | (self#html_of_example txt)) 45 | s 46 | examples; 47 | in 48 | Format.sprintf "%s
" s 49 | 50 | (** Redefine [html_of_custom] *) 51 | method html_of_custom b l = 52 | let examples = ref [] in 53 | List.iter 54 | (fun (tag, text) -> 55 | try 56 | if tag = "example" then examples := text :: !examples 57 | else assert false 58 | with 59 | Not_found -> 60 | Odoc_info.warning (Odoc_messages.tag_not_handled tag)) 61 | l; 62 | Buffer.add_string b (self#html_of_examples !examples) 63 | 64 | initializer 65 | tag_functions <- ("example", self#html_of_example) :: tag_functions 66 | end 67 | 68 | let () = 69 | Odoc_args.set_doc_generator (Some ((new example) :> Odoc_args.doc_generator)) 70 | -------------------------------------------------------------------------------- /utils/example.ml.4: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of Calendar. *) 4 | (* *) 5 | (* Copyright (C) 2003-2011 Julien Signoles *) 6 | (* *) 7 | (* you can redistribute it and/or modify it under the terms of the GNU *) 8 | (* Lesser General Public License version 2.1 as published by the *) 9 | (* Free Software Foundation, with a special linking exception (usual *) 10 | (* for Objective Caml libraries). *) 11 | (* *) 12 | (* It is distributed in the hope that it will be useful, *) 13 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 15 | (* *) 16 | (* See the GNU Lesser General Public Licence version 2.1 for more *) 17 | (* details (enclosed in the file LGPL). *) 18 | (* *) 19 | (* The special linking exception is detailled in the enclosed file *) 20 | (* LICENSE. *) 21 | (**************************************************************************) 22 | 23 | (** Version for OCaml 4.* *) 24 | 25 | (** Add a tag @example *) 26 | 27 | module Generator (G : Odoc_html.Html_generator) = 28 | struct 29 | class html = object (self) 30 | inherit G.html as super 31 | 32 | method private html_of_example txt = 33 | let buf = Buffer.create 97 in 34 | self#html_of_text buf txt; 35 | Format.sprintf "%s
\n" (Buffer.contents buf); 36 | 37 | method private html_of_examples = function 38 | | [] -> "" 39 | | [ txt ] -> Format.sprintf "Example: %s" (self#html_of_example txt) 40 | | examples -> 41 | let s = Format.sprintf "Examples:
    " in 42 | let s = 43 | List.fold_left 44 | (fun acc txt -> 45 | Format.sprintf "%s
  • %s
    • " 46 | acc 47 | (self#html_of_example txt)) 48 | s 49 | examples; 50 | in 51 | Format.sprintf "%s
" s 52 | 53 | (** Redefine [html_of_custom] *) 54 | method html_of_custom b l = 55 | let examples = ref [] in 56 | List.iter 57 | (fun (tag, text) -> 58 | try 59 | if tag = "example" then examples := text :: !examples 60 | else assert false 61 | with 62 | Not_found -> 63 | Odoc_info.warning (Odoc_messages.tag_not_handled tag)) 64 | l; 65 | Buffer.add_string b (self#html_of_examples !examples) 66 | 67 | initializer 68 | tag_functions <- ("example", self#html_of_example) :: tag_functions 69 | end 70 | end 71 | 72 | let () = 73 | Odoc_args.extend_html_generator 74 | (module Generator : Odoc_gen.Html_functor) 75 | --------------------------------------------------------------------------------