├── TODO ├── configure.in ├── CONFIGURE_HEADER ├── .github └── CODEOWNERS ├── headache_config.txt ├── .travis.yml ├── COPYING ├── HEADER ├── src ├── date.mli ├── time.mli ├── calendar.ml ├── fcalendar.ml ├── version.mli ├── ftime.mli ├── calendar.mli ├── fcalendar.mli ├── calendar_builder.mli ├── utils.ml ├── utils.mli ├── period.mli ├── time_Zone.ml ├── time_Zone.mli ├── time.ml ├── ftime.ml ├── time_sig.mli ├── printer.mli ├── calendar_sig.mli ├── date.ml └── calendar_builder.ml ├── tests ├── gen_test.mli ├── gen_test.ml ├── test.ml ├── test_timezone.ml ├── test_time.ml ├── test_ftime.ml ├── test_printer.ml ├── test_fpcalendar.ml ├── test_pcalendar.ml ├── test_fcalendar.ml ├── test_calendar.ml └── test_date.ml ├── man_date.txt ├── utils ├── example.ml.3 └── example.ml.4 ├── README.md ├── Makefile.in └── CHANGES /TODO: -------------------------------------------------------------------------------- 1 | 2 | Not used anymore. 3 | See http://forge.ocamlcore.org/pm/?group_id=83 4 | -------------------------------------------------------------------------------- /configure.in: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Leonidas-from-XIV/calendar/master/configure.in -------------------------------------------------------------------------------- /CONFIGURE_HEADER: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Leonidas-from-XIV/calendar/master/CONFIGURE_HEADER -------------------------------------------------------------------------------- /.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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | env: 6 | global: 7 | - PACKAGE=calendar 8 | matrix: 9 | - OCAML_VERSION=4.03 10 | - OCAML_VERSION=4.04 11 | - OCAML_VERSION=4.05 12 | - OCAML_VERSION=4.06 13 | - OCAML_VERSION=4.07 14 | os: 15 | - linux 16 | - osx 17 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/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/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/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/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 | val date: string 30 | (** Date of compilation. *) 31 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/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 | Printf.printf "%s\n" s; 44 | bug () 45 | with _ -> 46 | ok ();; 47 | -------------------------------------------------------------------------------- /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/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/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 | -------------------------------------------------------------------------------- /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 ok = 28 | Test_timezone.ok + Test_time.ok + Test_ftime.ok 29 | + Test_date.ok + Test_calendar.ok + Test_pcalendar.ok 30 | + Test_fcalendar.ok + Test_fpcalendar.ok 31 | + Test_printer.ok;; 32 | 33 | let bug = 34 | Test_timezone.bug + Test_time.bug + Test_ftime.bug 35 | + Test_date.bug + Test_calendar.bug + Test_pcalendar.bug 36 | + Test_fcalendar.bug + Test_fpcalendar.bug 37 | + Test_printer.bug;; 38 | 39 | Printf.printf "\nFinal results:\n";; 40 | Printf.printf "tests ok : %d; tests ko : %d\n" ok bug;; 41 | 42 | assert (bug >= 0);; 43 | 44 | if bug > 0 then exit 1;; 45 | -------------------------------------------------------------------------------- /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/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 = Pervasives.(=) 33 | let compare = Pervasives.compare 34 | let hash = Hashtbl.hash 35 | end 36 | 37 | module Float = struct 38 | 39 | type t = float 40 | 41 | let precision = ref 1e-3 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 | -------------------------------------------------------------------------------- /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 | Printf.printf "Tests of Time_Zone:\n";; 26 | 27 | open CalendarLib 28 | open Time_Zone;; 29 | include Gen_test;; 30 | reset ();; 31 | 32 | test (current () = UTC) "current () = UTC";; 33 | change Local;; 34 | test (current () = Local) "current () = Local";; 35 | test (gap UTC (UTC_Plus (-5)) = -5) "gap UTC (UTC_Plus (-5)) = -5";; 36 | let g6 = UTC_Plus 6;; 37 | test 38 | (gap g6 Local = gap g6 UTC + gap UTC Local) 39 | "gap g6 Local = gap g6 UTC + gap UTC Local";; 40 | test_exn (lazy (change (UTC_Plus 13))) "change 13";; 41 | test_exn (lazy (change (UTC_Plus (-15)))) "change (-15)";; 42 | change (UTC_Plus 4);; 43 | test (from_gmt () = 4) "from_gmt () = 4";; 44 | test (to_gmt () = -4) "to_gmt () = -4";; 45 | 46 | let ok = nb_ok ();; 47 | let bug = nb_bug ();; 48 | Printf.printf "tests ok : %d; tests ko : %d\n" ok bug;; 49 | flush stdout;; 50 | -------------------------------------------------------------------------------- /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-3] (that is one 62 | millisecond if floats represents seconds). *) 63 | 64 | val round: t -> int 65 | (** Round a float to the nearest integer. *) 66 | 67 | end 68 | -------------------------------------------------------------------------------- /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:" 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:" 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 | -------------------------------------------------------------------------------- /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/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 | | UTC_Plus x when out_of_bounds x -> invalid_arg "Not a valid time zone" 48 | | _ as t -> tz := t 49 | 50 | let gap t1 t2 = 51 | let aux t1 t2 = 52 | assert (t1 < t2); 53 | match t1, t2 with 54 | | UTC, Local -> gap_gmt_local 55 | | UTC, UTC_Plus x -> x 56 | | Local, UTC_Plus x -> x - gap_gmt_local 57 | | UTC_Plus x, UTC_Plus y -> y - x 58 | | _ -> assert false 59 | in 60 | let res = 61 | if t1 = t2 then 0 62 | else if t1 < t2 then aux t1 t2 63 | else - aux t2 t1 64 | in 65 | make_in_bounds res 66 | 67 | let from_gmt () = gap UTC (current ()) 68 | let to_gmt () = gap (current ()) UTC 69 | 70 | let is_dst () = 71 | current () = Local && (Unix.localtime (Unix.time ())).Unix.tm_isdst 72 | 73 | let hour_of_dst () = if is_dst () then 1 else 0 74 | 75 | let on f tz x = 76 | let old = current () in 77 | change tz; 78 | try 79 | let res = f x in 80 | change old; 81 | res 82 | with exn -> 83 | change old; 84 | raise exn 85 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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=master)](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 3.09.1 or higher. 20 | OCaml 3.09 is usable at your own risk. 21 | Older OCaml versions are unsupported. 22 | 23 | ## 2- Contents 24 | 25 | - `CHANGES` Information about the last changes 26 | - `COPYING` Information about copyright 27 | - `LGPL` Information about LGPL 28 | - `README.md` This file 29 | - `Makefile.in` Makefile used by configure 30 | - `configure` Script generating Makefile 31 | - `configure.in` Script generating configure (with autoconf) 32 | - `calendar_faq.txt` FAQ frow which some algorithms come 33 | - `doc` HTML documentation of the API 34 | - `src` Source files directory 35 | - `target` Directory containing the built library 36 | - `tests` Test files directory 37 | - `utils` Some utilities 38 | 39 | ## 3- Copyright 40 | 41 | This program is distributed under the GNU LGPL 2.1. 42 | See the enclosed file COPYING for more details. 43 | 44 | ## 4- Installation 45 | 46 | You need Objective Caml >= 3.09.1 to compile the sources. 47 | You need too ocamlfind coming with findlib and available at: 48 | http://www.ocaml-programming.de/packages/ 49 | 50 | 1. Configure with `./configure`. 51 | 2. Compile with `make`. 52 | 3. Install with `make install` (you may need superuser permissions). 53 | 4. Clean the directory with `make clean`. 54 | 55 | You can remove files installed by "make install" at any time with : 56 | 57 | `make uninstall` (you may need superuser permissions) 58 | 59 | ## 5- How to use 60 | 61 | (a) Use the GODI package of calendar ! 62 | 63 | see: http://godi.ocaml-programming.de 64 | 65 | (b) Or: simply link calendar with your files using ocamlfind. 66 | 67 | For example, if you have a file foo_using_calendar.ml, compile it as follow: 68 | 69 | ocamlfind ocamlc -package calendar -linkpkg foo_using_calendar.ml 70 | or 71 | 72 | ocamlfind ocamlopt -package calendar -linkpkg foo_using_calendar.ml 73 | 74 | (c) Or: do not use ocamlfind, link calendar with unix and str and 75 | specify the directory containing calendar: 76 | 77 | ocamlc -I /usr/local/lib/ocaml/site-lib/calendar unix.cma calendarLib.cmo foo_using_calendar.ml 78 | or 79 | 80 | ocamlopt -I /usr/local/lib/ocaml/site-lib/calendar unix.cmxa calendarLib.cmx foo_using_calendar.ml 81 | 82 | ## 6- Documentation 83 | 84 | The doc directory contains an html documentation of the .mli files. 85 | This documentation is available online at http://calendar.forge.ocamlcore.org/doc/ 86 | 87 | ## 7- Makefile 88 | 89 | A description of some Makefile entries follows : 90 | 91 | - i. tests 92 | Execute some tests 93 | 94 | - ii. wc 95 | Give informations about the size of the source files. You need ocamlwc `(*)`. 96 | 97 | - iii. doc 98 | Produce the documentation of the API. You need ocamldoc `(**)`. 99 | 100 | `(*)` ocamlwc is available at http://www.lri.fr/~filliatr/software.en.html 101 | `(**)` ocamldoc is included with Objective Caml 102 | 103 | ## 8- Contact the developers 104 | 105 | You can report bugs at https://github.com/ocaml-community/calendar/issues 106 | -------------------------------------------------------------------------------- /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 | Printf.printf "Tests of Time:\n";; 26 | 27 | open CalendarLib 28 | open Time;; 29 | include Gen_test;; 30 | reset ();; 31 | 32 | Time_Zone.change (Time_Zone.UTC_Plus 10);; 33 | 34 | test (make 30 60 80 = make 31 1 20) "30-60-80 = 31-1-20";; 35 | test (normalize (make 22 0 0) = (make 22 0 0, 0)) "normalize 22-0-0";; 36 | test (normalize (make 73 0 0) = (make 1 0 0, 3)) "normalize 73-0-0";; 37 | test (normalize (make (-73) 0 0) = (make 23 0 0, -4)) "normalize (-73)-0-0";; 38 | test (add (make 20 0 0) (Period.minute 70) = make 21 10 0) "add 20-0-0 70mn";; 39 | test (next (make 20 3 31) `Minute = make 20 4 31) "next 20-3-31 `Minute"; 40 | test (prev (make 20 3 31) `Second = make 20 3 30) "prev 20-3-31 `Second";; 41 | test (sub (make 6 5 4) (make 4 5 6) = Period.make 1 59 58) "sub 6-5-4 4-5-6";; 42 | test (convert (make 20 0 0) (Time_Zone.UTC_Plus 2) (Time_Zone.UTC_Plus 4) = 43 | make 22 0 0) "convert";; 44 | test (to_gmt (make 20 0 0) = make 10 0 0) "to_gmt";; 45 | test (from_gmt (make 20 0 0) = make 30 0 0) "from_gmt";; 46 | test (midnight () = make 0 0 0) "midnight";; 47 | test (midday () = make 12 0 0) "midday";; 48 | test (hour (make 20 0 0) = 20) "hour";; 49 | test (minute (make 20 10 0) = 10) "minute";; 50 | test (second (make 20 10 5) = 5) "second";; 51 | 52 | let one_two_three = make 1 2 3;; 53 | test (to_seconds one_two_three = 3723) "to_seconds";; 54 | test (Utils.Float.equal (to_minutes one_two_three) 62.05) "to_minutes";; 55 | test (to_hours (make 1 3 0) = 1.05) "to_hours";; 56 | test (from_seconds 3723 = from_minutes 62.05) "from_seconds; from_minutes";; 57 | test (from_hours 1.05 = make 1 3 0) "from_hours";; 58 | test (is_pm (midnight ())) "is_pm midnight";; 59 | test (is_pm (make 10 0 0)) "is_pm 10-0-0";; 60 | test (is_pm (make 34 0 0)) "is_pm 34-0-0";; 61 | test (not (is_pm (make (- 10) 0 0))) "not (is_pm (- 10) 0 0)";; 62 | test (is_am (midday ())) "is_am midday";; 63 | test (is_am (make 20 0 0)) "is_am 20-0-0";; 64 | test (is_am (make (- 34) 0 0)) "is_am (- 34) 0 0";; 65 | test (not (is_am (make 34 0 0))) "not (is_pm 34 0 0)";; 66 | 67 | let one_two_three = Period.make 1 2 3;; 68 | test (Period.to_seconds one_two_three = 3723) "Period.to_seconds";; 69 | test (Utils.Float.equal (Period.to_minutes one_two_three) 62.05) 70 | "Period.to_minutes";; 71 | test (Utils.Float.equal (Period.to_hours (Period.make 1 3 0)) 1.05) 72 | "Period.to_hours";; 73 | 74 | let ok = nb_ok ();; 75 | let bug = nb_bug ();; 76 | Printf.printf "tests ok : %d; tests ko : %d\n" ok bug;; 77 | flush stdout;; 78 | -------------------------------------------------------------------------------- /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 | Printf.printf "Tests of Ftime:\n";; 26 | 27 | open CalendarLib 28 | open Ftime;; 29 | include Gen_test;; 30 | reset ();; 31 | 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 | let one_two_three = make 1 2 3.;; 58 | test (to_seconds one_two_three = 3723.) "to_seconds";; 59 | test (to_minutes one_two_three = 62.05) "to_minutes";; 60 | test (Utils.Float.equal (to_hours (make 1 3 0.4)) 1.050111) "to_hours";; 61 | test (equal (from_seconds 3723.2) (from_minutes 62.053333333)) 62 | "from_seconds; from_minutes";; 63 | test (from_hours 1.05 = make 1 3 0.) "from_hours";; 64 | test (is_pm (midnight ())) "is_pm midnight";; 65 | test (is_pm (make 10 0 0.)) "is_pm 10-0-0";; 66 | test (is_pm (make 34 0 0.)) "is_pm 34-0-0";; 67 | test (not (is_pm (make (- 10) 0 0.))) "not (is_pm (- 10) 0 0)";; 68 | test (is_am (midday ())) "is_am midday";; 69 | test (is_am (make 20 0 0.)) "is_am 20-0-0";; 70 | test (is_am (make (- 34) 0 0.)) "is_am (- 34) 0 0";; 71 | test (not (is_am (make 34 0 0.))) "not (is_pm 34 0 0)";; 72 | 73 | let one_two_three = Period.make 1 2 3.;; 74 | test (Utils.Float.equal (Period.to_seconds one_two_three) 3723.) 75 | "Period.to_seconds";; 76 | test (Utils.Float.equal (Period.to_minutes one_two_three) 62.05) 77 | "Period.to_minutes";; 78 | test (Utils.Float.equal (Period.to_hours (Period.make 1 3 0.1)) 1.050028) 79 | "Period.to_hours";; 80 | 81 | let ok = nb_ok ();; 82 | let bug = nb_bug ();; 83 | Printf.printf "tests ok : %d; tests ko : %d\n" ok bug;; 84 | flush stdout;; 85 | -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /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 | Printf.printf "Tests of Printer:\n";; 24 | 25 | open CalendarLib;; 26 | include Gen_test;; 27 | reset ();; 28 | 29 | open Printer.Date;; 30 | let d = Date.make 2003 1 6;; 31 | test (sprint "%D" d = "01/06/03") "sprint %D";; 32 | test (sprint "the date is %B, the %-dth" d = "the date is January, the 6th") 33 | "sprint (long sentence)";; 34 | test (sprint "%^B, the %0dth" d = "JANUARY, the 06th") "sprint padding";; 35 | test (sprint "%j" d = "006") "sprint %j";; 36 | test (sprint "%-j" d = "6") "sprint %j";; 37 | test (sprint "%_j" d = " 6") "sprint %j";; 38 | test (sprint "%j" (Date.make 2003 1 10) = "010") "sprint %j";; 39 | test (sprint "%-j" (Date.make 2003 1 10) = "10") "sprint %j";; 40 | test (sprint "%_j" (Date.make 2003 1 10) = " 10") "sprint %j";; 41 | test (sprint "%C" (Date.make 2008 12 5) = "21") "sprint %C";; 42 | test (from_string "2003-01-06" = Date.make 2003 1 6) "from_string";; 43 | test (from_fstring "%y-%m-%d" "03-01-06" = Date.make 1903 1 6) "from_fstring";; 44 | test 45 | (from_fstring "%Y%t%m%t%d" "1903\t01\t06" = Date.make 1903 1 6) 46 | "from_fstring %t";; 47 | test 48 | (from_fstring "%Y-%B-%d" "2007-May-14" = Date.make 2007 5 14) 49 | "from_fstring %B";; 50 | 51 | test 52 | (from_fstring "%Y-%b-%d" "2007-Jan-14" = Date.make 2007 1 14) 53 | "from_fstring %B";; 54 | 55 | test (from_fstring "%Y %V %w" "2004 01 1" = Date.make 2003 12 29) 56 | "from_fstring %Y %V %w";; 57 | test (from_fstring "%V %Y %w" "52 1999 7" = Date.make 2000 1 2) 58 | "from_fstring %V %Y %w";; 59 | test_exn (lazy (from_fstring "%Y %w" "1999 7")) "from_fstring_exn";; 60 | test (from_fstring "%Y%j" "1903001" = Date.make 1903 1 1) "from_fstring %Y%j";; 61 | test (from_fstring "%j%Y" "0011903" = Date.make 1903 1 1) "from_fstring %j%Y";; 62 | test_exn (lazy (from_fstring "%j" "001")) "from_fstring_exn 2";; 63 | 64 | open Printer.Time;; 65 | test (to_string (Time.make 12 1 4) = "12:01:04") "to_string (on TimePrinter)";; 66 | test (sprint "%I" (Time.make 36 4 3) = "12") "sprint %I (on TimePrinter)";; 67 | test (sprint "%r" (Time.make 24 4 3) = "12:04:03 AM") 68 | "sprint %r (on TimePrinter)";; 69 | test (sprint "%R %z" (Time.make 12 24 5) = "12:24 +0000") "sprint %R %z";; 70 | test 71 | (Time_Zone.on (fun () -> sprint "%R %z" (Time.make 12 24 5)) 72 | (Time_Zone.UTC_Plus (-3)) () = "12:24 -0300") 73 | "sprint %R %z neg";; 74 | test (sprint "%R %S %:z" (Time.make 23 47 55) = "23:47 55 +00:00") 75 | "sprint %R %S %:z";; 76 | test 77 | (Time_Zone.on (fun () -> sprint "%R %S %::z" (Time.make 7 47 55)) 78 | (Time_Zone.UTC_Plus 3) () = "07:47 55 +03:00:00") 79 | "sprint %R %S %::z";; 80 | test_exn (lazy (sprint "%R %:a" (Time.make 23 47 55))) "sprint %R %:a";; 81 | test_exn (lazy (sprint "%::::z %R" (Time.make 23 47 55))) "sprint %::::z %R";; 82 | 83 | test (from_fstring "%R %S %z" "10:47 55 -0300" = Time.make 13 47 55) 84 | "from_fstring %R %S %z";; 85 | test (from_fstring "%R %S %:z" "10:47 55 -13:00" = Time.make 23 47 55) 86 | "from_fstring %R %S %:z";; 87 | test_exn (lazy (from_fstring "%R %S %:z" "10:47 55 -0300")) 88 | "from_fstring %R %S %:z bug1";; 89 | test_exn (lazy (from_fstring "%R %S %:z" "10:47 55 -03:00:00")) 90 | "from_fstring %R %S %:z bug2";; 91 | test (from_fstring "%R %S %::z" "10:47 55 +03:00:00" = Time.make 7 47 55) 92 | "from_fstring %R %S %::z";; 93 | test (from_fstring "%R %S %:::z" "10:47 55 -03" = Time.make 13 47 55) 94 | "from_fstring %R %S %:::z";; 95 | test_exn (lazy (from_fstring "%R %S %::::z" "10:47 55 -0300")) 96 | "from_fstring %R %S %::::z";; 97 | test (from_fstring "%r" "10:47:25 AM" = Time.make 10 47 25) 98 | "from_fstring AM (on TimePrinter)";; 99 | test (from_fstring "%r" "10:47:25 PM" = Time.make 22 47 25) 100 | "from_fstring PM (on TimePrinter)";; 101 | test_exn (lazy (from_fstring "%p %I:%M:%S" "TM 5:26:17")) 102 | "from_fstring error on %p (on TimePrinter)";; 103 | 104 | open Printer.Calendar;; 105 | test (sprint "%c" (Calendar.make 2003 1 6 12 1 4) = "Mon Jan 06 12:01:04 2003") 106 | "sprint %c";; 107 | test (to_string (Calendar.make 2004 10 25 24 0 1) = "2004-10-26 00:00:01") 108 | "to_string (on CalendarPrinter)";; 109 | test 110 | (from_fstring "%c" "Mon May 14 10:30:00 2007" 111 | = Calendar.make 2007 5 14 10 30 0) 112 | "from_fstring (on CalendarPrinter)";; 113 | test (sprint "%s" (Calendar.make 1971 1 1 0 0 0) = "31536000") 114 | "sprint %s";; 115 | 116 | test (Utils.Float.equal 117 | (Ftime.second 118 | (Printer.Ftime.from_fstring 119 | "%Y-%m-%dT%H:%M:%S%:z" "2014-03-19T15:51:25.05-07:00")) 120 | 25.05) 121 | "from_string with floating seconds";; 122 | 123 | let ok = nb_ok ();; 124 | let bug = nb_bug ();; 125 | Printf.printf "tests ok : %d; tests ko : %d\n" ok bug;; 126 | flush stdout;; 127 | -------------------------------------------------------------------------------- /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 | Printf.printf "Tests of FPcalendar:\n";; 26 | 27 | open CalendarLib;; 28 | open Fcalendar.Precise;; 29 | include Gen_test;; 30 | reset ();; 31 | 32 | let eps = 0.000001;; 33 | 34 | Time_Zone.change Time_Zone.UTC;; 35 | 36 | (* Fcalendar *) 37 | 38 | 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.;; 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.;; 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;; 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 ();; 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 | 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 | let ok = nb_ok ();; 170 | let bug = nb_bug ();; 171 | Printf.printf "tests ok : %d; tests ko : %d\n" ok bug;; 172 | flush stdout;; 173 | -------------------------------------------------------------------------------- /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 | Printf.printf "Tests of Precise Calendar:\n";; 26 | 27 | open CalendarLib;; 28 | open Calendar.Precise;; 29 | include Gen_test;; 30 | reset ();; 31 | 32 | let eps = 0.000001;; 33 | 34 | Time_Zone.change Time_Zone.UTC;; 35 | 36 | (* Calendar *) 37 | 38 | 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 | 57 | test 58 | (add (make 1 2 3 4 5 6) (Period.make 9 8 7 6 5 4) = make 10 10 10 10 10 10) 59 | "add 1-2-3-4-5-6 9-8-7-6-5-4";; 60 | test 61 | (add (make 3 1 1 0 0 0) (Period.make 0 0 0 (-25) 0 (-1)) = 62 | make 2 12 30 22 59 59) 63 | "add 3-1-1-0-0-0 0-0-0-(-25)-0-(-1)";; 64 | 65 | test 66 | (equal (rem (make 9 8 7 6 5 4) (Period.make 1 2 3 4 5 6)) 67 | (make 8 6 4 1 59 58)) 68 | "rem 9-8-7-6-5-4 1-2-3-4-5-6";; 69 | test (sub (make 0 0 7 6 5 4) (make 0 0 3 54 5 6) = Period.make 0 0 1 23 59 58) 70 | "sub 0-0-7-6-5-4 0-0-3-54-5-6";; 71 | 72 | test (Period.equal 73 | (Period.opp (Period.make 0 0 2 3 0 0)) 74 | (Period.make 0 0 (-2) (-3) 0 0)) 75 | "period opp";; 76 | 77 | (* Date *) 78 | 79 | let d = make 2003 12 31 12 24 48;; 80 | test (next d `Month = make 2004 1 31 12 24 48) "2003-12-31 + 1 mois";; 81 | test (add d (Period.month 2) = make 2004 3 2 12 24 48) "2003-12-31 + 2 mois";; 82 | let d3 = make 2011 3 24 0 0 0;; 83 | test (prev d3 `Year = make 2010 3 24 0 0 0) "2011-3-24 - 1 year";; 84 | let d2 = make (-3000) 1 1 6 12 24;; 85 | test (equal (rem d (sub d d2)) d2) "rem x (sub x y) = y";; 86 | test (is_leap_day (make 2000 2 24 0 0 0)) "2000-2-24 leap day";; 87 | test (not (is_leap_day (make 2000 2 25 0 0 0))) "2000-2-25 not leap day";; 88 | test (is_gregorian (make 1600 1 1 0 0 0)) "1600-1-1 gregorian";; 89 | test (not (is_gregorian (make 1400 1 1 0 0 0))) "1400-1-1 not gregorian";; 90 | test (is_julian (make 1582 1 1 0 0 0)) "1582-1-1 julian";; 91 | test (not (is_julian (make 1583 1 1 0 0 0))) "1583-1-1 not julian";; 92 | 93 | (* Time *) 94 | 95 | test (let n = Unix.gmtime (Unix.time ()) in 96 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant UTC";; 97 | test (let n = Unix.time () in 98 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 99 | "from_unixfloat invariant UTC";; 100 | 101 | Time_Zone.change (Time_Zone.UTC_Plus 10);; 102 | 103 | test (let n = Unix.gmtime (Unix.time ()) in 104 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant +10";; 105 | test (let n = Unix.time () in 106 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 107 | "from_unixfloat invariant +10";; 108 | 109 | test (equal (add (make 0 0 0 10 0 0) (Period.hour 30)) (make 0 0 1 16 0 0)) 110 | "add 0-0-0-20-0-0 30h";; 111 | test (equal (next (make 1999 12 31 23 59 59) `Second) (make 2000 1 1 0 0 0)) 112 | "next 1999-31-12-23-59-59 `Second";; 113 | let n = now ();; 114 | test (equal (prev (next n `Minute) `Minute) n) "prev next = id";; 115 | 116 | test (equal 117 | (convert 118 | (make 0 0 0 23 0 0) 119 | (Time_Zone.UTC_Plus 2) 120 | (Time_Zone.UTC_Plus 4)) 121 | (make 0 0 1 1 0 0)) "convert";; 122 | test (hour (make 0 0 0 20 0 0) = 20) "hour";; 123 | test (minute (make 0 0 0 20 10 0) = 10) "minute";; 124 | test (second (make 0 0 0 20 10 5) = 5) "second";; 125 | test (is_pm (make 0 0 0 10 0 0)) "is_pm 10-0-0";; 126 | test (is_pm (make 0 0 0 34 0 0)) "is_pm 34-0-0";; 127 | test (not (is_pm (make 0 0 0 (- 10) 0 0))) "not (is_pm (- 10) 0 0)";; 128 | test (is_am (make 0 0 0 20 0 0)) "is_am 20-0-0";; 129 | test (is_am (make 0 0 0 (- 34) 0 0)) "is_am (- 34) 0 0";; 130 | test (not (is_am (make 0 0 0 34 0 0))) "not (is_pm 34 0 0)";; 131 | 132 | Time_Zone.change Time_Zone.UTC;; 133 | 134 | test (let n = Unix.gmtime (Unix.time ()) in 135 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant UTC2";; 136 | test (let n = Unix.time () in 137 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 138 | "from_unixfloat invariant UTC2";; 139 | 140 | test (to_unixfloat (make 1970 1 1 0 0 0) = 0.) "to_unixfloat 1 Jan 1970";; 141 | test (from_unixfloat 0. = make 1970 1 1 0 0 0) "from_unixfloat 1 Jan 1970";; 142 | test (Utils.Float.equal (to_unixfloat (make 2004 11 13 19 17 9)) 1100373429.) 143 | "to_unixfloat";; 144 | test (equal (from_unixfloat 1100373429.) (make 2004 11 13 19 17 9)) 145 | "from_unixfloat";; 146 | test (from_unixtm (to_unixtm (make 2003 7 16 23 22 21)) = 147 | make 2003 7 16 23 22 21) 148 | "from_unixtm to_unixtm = id";; 149 | 150 | test (Period.to_time (Period.second 30) = Time.Period.second 30) 151 | "Period.to_time second";; 152 | test (Period.safe_to_time (Period.second 30) = Time.Period.second 30) 153 | "Period.safe_to_time second";; 154 | test (Period.to_time (Period.day 6) = Time.Period.second 518400) 155 | "Period.to_time day";; 156 | test (Period.safe_to_time (Period.day 6) = Time.Period.second 518400) 157 | "Period.safe_to_time day";; 158 | test_exn (lazy (Period.to_time (Period.year 1))) "Period.to_time year";; 159 | test (Period.ymds (Period.make 1 2 3 1 2 3) = (1, 2, 3, 3723)) "Period.ymds";; 160 | test 161 | (Period.ymds (Period.make (-1) (-2) (-3) (-1) (-2) (-3)) = (-1,-2,-4,82677)) 162 | "Period.ymds neg";; 163 | 164 | let ok = nb_ok ();; 165 | let bug = nb_bug ();; 166 | Printf.printf "tests ok : %d; tests ko : %d\n" ok bug;; 167 | flush stdout;; 168 | -------------------------------------------------------------------------------- /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 | Printf.printf "Tests of Fcalendar:\n";; 26 | 27 | open CalendarLib;; 28 | open Fcalendar;; 29 | include Gen_test;; 30 | reset ();; 31 | 32 | let eps = 0.000001;; 33 | 34 | Time_Zone.change Time_Zone.UTC;; 35 | 36 | (* Fcalendar *) 37 | 38 | 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.;; 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.;; 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;; 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 ();; 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 | (* Loss of precision *) 128 | test (hour (make 0 0 0 20 0 0.) = 19) "hour";; 129 | test (hour (make 0 0 0 20 0 0.2) = 20) "hour";; 130 | 131 | test (minute (make 0 0 0 20 10 0.2) = 10) "minute";; 132 | 133 | (* Loss of precision *) 134 | test (Utils.Float.equal (second (make 0 0 0 20 10 5.123)) 5.123004) "second";; 135 | 136 | test (is_pm (make 0 0 0 10 0 0.1)) "is_pm 10-0-0";; 137 | test (is_pm (make 0 0 0 34 0 0.)) "is_pm 34-0-0";; 138 | test (not (is_pm (make 0 0 0 (- 10) 0 0.))) "not (is_pm (- 10) 0 0)";; 139 | test (is_am (make 0 0 0 20 0 0.)) "is_am 20-0-0";; 140 | test (is_am (make 0 0 0 (- 34) 0 0.)) "is_am (- 34) 0 0";; 141 | test (not (is_am (make 0 0 0 34 0 0.))) "not (is_pm 34 0 0)";; 142 | 143 | Time_Zone.change Time_Zone.UTC;; 144 | 145 | test (let n = Unix.gmtime (Unix.time ()) in 146 | hour (from_unixtm n) = n.Unix.tm_hour) "from_unixtm invariant UTC2";; 147 | test (let n = Unix.time () in 148 | hour (from_unixfloat n) = (Unix.gmtime n).Unix.tm_hour) 149 | "from_unixfloat invariant UTC2";; 150 | 151 | test (to_unixfloat (make 1970 1 1 0 0 0.) = 0.) "to_unixfloat 1 Jan 1970";; 152 | test (from_unixfloat 0. = make 1970 1 1 0 0 0.) "from_unixfloat 1 Jan 1970";; 153 | test (Utils.Float.equal (to_unixfloat (make 2004 11 13 19 17 9.)) 1100373429.) 154 | "to_unixfloat";; 155 | test (equal (from_unixfloat 1100373429.) (make 2004 11 13 19 17 9.)) 156 | "from_unixfloat";; 157 | 158 | (* Loss of precision *) 159 | test (equal 160 | (from_unixtm (to_unixtm (make 2003 7 16 23 22 21.))) 161 | (make 2003 7 16 23 22 20.)) 162 | "from_unixtm to_unixtm = id";; 163 | 164 | test (Period.to_time (Period.second 30.12) = Time.Period.second 30.12) 165 | "Period.to_time second";; 166 | test (Period.to_time (Period.day 6) = Time.Period.second 518400.) 167 | "Period.to_time day";; 168 | test (Period.safe_to_time (Period.second 30.12) = Time.Period.second 30.12) 169 | "Period.safe_to_time second";; 170 | test (Period.safe_to_time (Period.day 6) = Time.Period.second 518400.) 171 | "Period.safe_to_time day";; 172 | test_exn (lazy (Period.to_time (Period.year 1))) "Period.to_time year";; 173 | test (Period.ymds (Period.make 1 2 3 1 2 3.1) = (1, 2, 3, 3723.1)) 174 | "Period.ymds";; 175 | test 176 | (Period.ymds (Period.make (-1) (-2) (-3) (-1) (-2) (-3.)) = (-1,-2,-4,82677.)) 177 | "Period.ymds neg";; 178 | 179 | let ok = nb_ok ();; 180 | let bug = nb_bug ();; 181 | Printf.printf "tests ok : %d; tests ko : %d\n" ok bug;; 182 | flush stdout;; 183 | -------------------------------------------------------------------------------- /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 | include Gen_test;; 28 | reset ();; 29 | 30 | let eps = 0.000001;; 31 | 32 | Time_Zone.change Time_Zone.UTC;; 33 | 34 | (* Calendar *) 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 | 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;; 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;; 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;; 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 ();; 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 | 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 | let ok = nb_ok ();; 197 | let bug = nb_bug ();; 198 | Printf.printf "tests ok : %d; tests ko : %d\n" ok bug;; 199 | flush stdout;; 200 | -------------------------------------------------------------------------------- /Makefile.in: -------------------------------------------------------------------------------- 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 | # Used programs 24 | ############### 25 | 26 | CAMLC = @OCAMLC@ 27 | CAMLOPT = @OCAMLOPT@ 28 | CAMLDEP = @OCAMLDEP@ 29 | CAMLDOC = @OCAMLDOC@ 30 | CAMLWEB = @OCAMLWEB@ 31 | CAMLWC = @OCAMLWC@ 32 | CAMLDOT = @OCAMLDOT@ 33 | CAMLLIB = @OCAMLLIB@ 34 | CAMLFIND= @OCAMLFIND@ 35 | CAMLMAJORVERSION= @OCAMLMAJOR@ 36 | 37 | # Object/Library File Extensions 38 | OBJ_EXT = @OBJEXT@ 39 | LIB_EXT = @LIBEXT@ 40 | 41 | HAS_NATDYNLINK=@HAS_NATDYNLINK@ 42 | 43 | # Project 44 | ######### 45 | 46 | NAME = calendar 47 | NAMELIB = calendarLib 48 | VERSION = 2.04 49 | 50 | LIBDIR = target 51 | 52 | LIBS = $(LIBDIR)/$(NAMELIB).cmo $(LIBDIR)/$(NAMELIB).cma 53 | CLIBS = 54 | ifneq ($(CAMLOPT),no) 55 | LIBS := $(LIBS) $(LIBDIR)/$(NAMELIB).cmx $(LIBDIR)/$(NAMELIB).cmxa 56 | ifeq ($(HAS_NATDYNLINK),yes) 57 | LIBS := $(LIBS) $(LIBDIR)/$(NAMELIB).cmxs 58 | endif 59 | CLIBS := $(CLIBS) $(LIBDIR)/$(NAMELIB)$(OBJ_EXT) \ 60 | $(LIBDIR)/$(NAMELIB)$(LIB_EXT) 61 | endif 62 | 63 | DIRS = src target tests 64 | 65 | SRC = utils.mli utils.ml time_Zone.mli time_Zone.ml period.mli \ 66 | time_sig.mli time.mli time.ml ftime.mli ftime.ml \ 67 | date_sig.mli date.mli date.ml \ 68 | calendar_sig.mli calendar_builder.mli calendar_builder.ml \ 69 | calendar.mli calendar.ml fcalendar.mli fcalendar.ml \ 70 | printer.mli printer.ml \ 71 | version.mli version.ml 72 | SRC := $(addprefix src/, $(SRC)) 73 | 74 | ML = $(filter %.ml, $(SRC)) 75 | MLI = $(filter %.mli, $(SRC)) 76 | 77 | CMO = $(ML:.ml=.cmo) 78 | CMX = $(CMO:.cmo=.cmx) 79 | CMI = $(MLI:.mli=.cmi) 80 | CMI_ONLY= src/period.cmi src/date_sig.cmi src/time_sig.cmi src/calendar_sig.cmi 81 | 82 | GENERATED= src/version.ml 83 | 84 | # Libs and flags 85 | ################ 86 | 87 | CAMLIBS = $(addprefix -I , $(DIRS)) 88 | 89 | CAMLFLAGS= $(CAMLIBS) 90 | BYTEFLAGS= $(CAMLFLAGS) 91 | LINK_OPTFLAGS = $(CAMLFLAGS) -noassert 92 | OPTFLAGS = $(LINK_OPTFLAGS) -for-pack CalendarLib 93 | 94 | # Main rules 95 | ############ 96 | 97 | all: $(LIBS) META 98 | 99 | $(LIBDIR)/$(NAMELIB).cmo: $(CMI_ONLY) $(CMO) 100 | mkdir -p $(LIBDIR) 101 | $(CAMLFIND) ocamlc $(BYTEFLAGS) -pack -o $@ \ 102 | $(filter-out $(LIBDIR), $^) 103 | 104 | $(LIBDIR)/$(NAMELIB).cma: $(LIBDIR)/$(NAMELIB).cmo 105 | $(CAMLFIND) ocamlc $(BYTEFLAGS) -a -o $@ $< 106 | 107 | $(LIBDIR)/$(NAMELIB).cmx: $(CMI_ONLY) $(CMX) 108 | mkdir -p $(LIBDIR) 109 | $(CAMLFIND) ocamlopt $(LINK_OPTFLAGS) -pack -o $@ \ 110 | $(filter-out $(LIBDIR), $^) 111 | 112 | $(LIBDIR)/$(NAMELIB).a $(LIBDIR)/$(NAMELIB).cmxa: $(LIBDIR)/$(NAMELIB).cmx 113 | $(CAMLFIND) ocamlopt $(LINK_OPTFLAGS) -a -o $@ $< 114 | 115 | $(LIBDIR)/$(NAMELIB).cmxs: $(LIBDIR)/$(NAMELIB).cmxa 116 | $(CAMLFIND) ocamlopt -I $(LIBDIR) -shared -linkall -o $@ $< 117 | 118 | src/version.ml: Makefile 119 | echo "let version = \"$(VERSION)\"" > $@ 120 | echo "let date = \"`date`\"" >> $@ 121 | 122 | META: Makefile 123 | echo "name = \"$(NAME)\"" > $@ 124 | echo "description = \"$(NAME) library\"" >> $@ 125 | echo "version = \"$(VERSION)\"" >> $@ 126 | echo "archive(byte) = \"$(NAMELIB).cma\"" >> $@ 127 | echo "archive(native) = \"$(NAMELIB).cmxa\"" >> $@ 128 | echo "requires = \"unix str\"" >> $@ 129 | 130 | # Generic rules 131 | ############### 132 | 133 | %.gz: % 134 | gzip -f --best $< 135 | 136 | .SUFFIXES: .ml .mli .cmo .cmi .cmx $(OBJ_EXT) 137 | 138 | .mli.cmi: 139 | $(CAMLC) $(BYTEFLAGS) -c $< 140 | 141 | .ml.cmo: 142 | $(CAMLC) $(BYTEFLAGS) -c $< 143 | 144 | .ml$(OBJ_EXT): 145 | $(CAMLOPT) $(OPTFLAGS) -c $< 146 | 147 | .ml.cmx: 148 | $(CAMLOPT) $(OPTFLAGS) -c $< 149 | 150 | # Tests 151 | ####### 152 | 153 | TESTS_SRC= gen_test.mli gen_test.ml test_timezone.ml test_time.ml \ 154 | test_ftime.ml test_date.ml test_calendar.ml test_fcalendar.ml \ 155 | test_pcalendar.ml test_fpcalendar.ml test_printer.ml test.ml 156 | TESTS_SRC:= $(addprefix tests/, $(TESTS_SRC)) 157 | 158 | TESTS_ML= $(filter %.ml, $(TESTS_SRC)) 159 | TESTS_CMO= $(TESTS_ML:.ml=.cmo) 160 | 161 | $(TESTS_CMO) $(TESTS_CMI): $(LIBDIR)/$(NAMELIB).cmo $(LIBDIR)/$(NAMELIB).cmi 162 | 163 | tests/test: $(LIBDIR)/$(NAMELIB).cmo $(TESTS_CMO) 164 | $(CAMLC) -o $@ $(BYTEFLAGS) unix.cma str.cma $(LIBDIR)/$(NAMELIB).cmo \ 165 | $(TESTS_CMO) 166 | 167 | .PHONY: tests 168 | tests: tests/test 169 | ./$< 170 | 171 | # Documentation 172 | ############### 173 | 174 | wc: $(SRC) 175 | $(CAMLWC) -p $^ 176 | 177 | $(NAMELIB).ps: $(SRC) 178 | $(CAMLWEB) --ps -o $@ $^ 179 | 180 | ifeq ($(CAMLMAJORVERSION),3) 181 | utils/example.ml: utils/example.ml.3 Makefile 182 | cp $< $@ 183 | else 184 | utils/example.ml: utils/example.ml.4 Makefile 185 | cp $< $@ 186 | endif 187 | 188 | utils/example.cmo: utils/example.ml 189 | $(CAMLC) -I +ocamldoc -I utils -c $< 190 | 191 | .PHONY: doc 192 | doc: $(CMO) utils/example.cmo 193 | mkdir -p doc 194 | rm -f doc/* 195 | $(CAMLDOC) -g utils/example.cmo -colorize-code -I src -d doc \ 196 | $(MLI) $(ML) 197 | 198 | # Headers 199 | ######### 200 | 201 | .PHONY: headers 202 | headers: 203 | headache -c headache_config.txt -h HEADER $(SRC) $(TESTS_SRC) \ 204 | Makefile.in utils/example.ml 205 | headache -c headache_config.txt -h CONFIGURE_HEADER configure.in 206 | 207 | # Install 208 | ######### 209 | 210 | install: $(LIBS) $(CLIBS) META 211 | @if [ "`sed -n -e 's/version = "\([0-9.+dev]*\)"/\1/p' META`" = "$(VERSION)" ]; then \ 212 | (if test -d `ocamlfind install -help | grep destdir | sed -e "s/.*default: \(.*\))/\1/"`/$(NAME); then $(MAKE) uninstall; fi;\ 213 | $(CAMLFIND) install $(NAME) target/*.cm* $(MLI) $(CLIBS) META); \ 214 | else \ 215 | (echo; echo "Not the good version. Please, do :"; \ 216 | echo " make clean && make"; \ 217 | echo "next reinstall"; echo) \ 218 | fi 219 | 220 | uninstall: 221 | $(CAMLFIND) remove $(NAME) 222 | 223 | # Exporting 224 | ########### 225 | 226 | EXPORT_DIR= $$HOME/EXPORT/$(NAME) 227 | TMP_DIR = $$HOME/tmp 228 | 229 | ROOT= $$HOME/DEV/calendar 230 | 231 | export: doc 232 | (cd $(TMP_DIR); \ 233 | svn co svn+ssh://signoles@svn.forge.ocamlcore.org/svnroot/calendar/trunk) 234 | svn copy $(TMP_DIR)/trunk $(ROOT)/tags/v$(VERSION) 235 | rm -rf $(TMP_DIR)/trunk 236 | (cd $(ROOT)/tags; svn commit -m "v $(VERSION)") 237 | rm -rf $(EXPORT_DIR)/doc 238 | mkdir -p $(EXPORT_DIR) 239 | cp -rf CHANGES doc $(EXPORT_DIR) 240 | cp -rf $(ROOT)/tags/v$(VERSION) $(TMP_DIR)/$(NAME)-$(VERSION) 241 | cp -rf .depend configure config.status doc $(TMP_DIR)/$(NAME)-$(VERSION) 242 | cd $(TMP_DIR); \ 243 | (rm -rf $(NAME)-$(VERSION)/.svn $(NAME)-$(VERSION)/*/.svn; \ 244 | tar cvf $(NAME)-$(VERSION).tar $(NAME)-$(VERSION); \ 245 | gzip -f --best $(NAME)-$(VERSION).tar; \ 246 | rm -rf $(NAME)-$(VERSION); \ 247 | mv $(NAME)-$(VERSION).tar.gz $(EXPORT_DIR)) 248 | rm -rf $(TMP_DIR)/$(NAME)-$(VERSION) 249 | 250 | # Rebuilding Makefile 251 | ##################### 252 | 253 | Makefile: Makefile.in 254 | ./config.status 255 | 256 | config.status: configure 257 | ./config.status --recheck 258 | 259 | configure: configure.in 260 | autoconf 261 | 262 | # Emacs tags 263 | ############ 264 | 265 | TAGS: $(SRC) 266 | otags -o $@ $^ 267 | 268 | # Cleaning 269 | ########## 270 | 271 | clean: 272 | rm -f TAGS META $(TESTS) tests/test $(GENERATED) 273 | for i in . src tests utils; do \ 274 | rm -f $$i/*~ $$i/\#* $$i/*.cm[iox] $$i/*.*a $$i/*$(OBJ_EXT) $$i/a.out; \ 275 | done 276 | rm -f utils/example.ml 277 | 278 | dist-clean distclean: clean 279 | rm -rf $(NAME).ps.gz doc $(LIBDIR) 280 | 281 | clean-configure cleanconfig: dist-clean 282 | rm -f Makefile configure config.* 283 | 284 | # Depend 285 | ######## 286 | 287 | .depend depend: $(GENERATED) 288 | rm -f .depend 289 | $(CAMLDEP) -I src -I tests src/*.ml src/*.mli tests/*.ml tests/*.mli \ 290 | > .depend 291 | 292 | view-depend: 293 | $(CAMLDOT) .depend | dot -Tps | gv - 294 | 295 | include .depend 296 | -------------------------------------------------------------------------------- /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 2.04, 2014-10-29: 10 | =========================== 11 | * [Makefile] Fix minor issues with ocamlfind and 'make install' (from 12 | Christopher Zimmermann). 13 | o [Printer] In function from_fstring of sub-module Ftime, Fcalendar, and 14 | Precise_Fcalendar, the number of seconds corresponding to %S may be a floating 15 | point number (from Christophe Troestler' suggestion). 16 | 17 | version 2.03.2, 2012-06-26: 18 | =========================== 19 | o [Compilation] Compatibility with OCaml 4 20 | 21 | version 2.03.1, 2011-03-24: 22 | =========================== 23 | * [Calendar] Fixed bug in Calendar.prev and Fcalendar.prev: mostly raised 24 | exception Date.Out_of_bounds before. 25 | * [Printer] `Thurday' was printed instead of `Thursday' 26 | 27 | version 2.03, 2010-07-05: 28 | ========================= 29 | o [Date] new function Date.precise_sub 30 | o [Calendar] new function Calendar.precise_sub 31 | (from Dario Teixeira's suggestion) 32 | * [Compilation] detect whether native dynlink works 33 | (prevents compilation bug on Mac OS X) 34 | 35 | version 2.02, 2009-12-11: 36 | ========================= 37 | o [License] add the usual Ocaml linking exception in the license 38 | o [Calendar] Calendar_sig.Period.to_time is deprecated. 39 | Replaced by a new function Calendar_sig.Period.safe_to_time 40 | o [Date] Date.Period.nb_days is deprecated. 41 | Replaced by a new function Date.Period.safe_nb_days 42 | o [Compilation] calendarLib.cmxs provided if ocaml >= 3.11 is installed 43 | (patch of Mehdi Dogguy) 44 | o [Date] new functions Date.make_year and Date.make_year_month 45 | o [Date] improve memory representation of Date.Period.t 46 | * [Compilation] remove installation of packed *.cmi 47 | * [Compilation] bug fixed under Cygwin 48 | * [Compilation] META files was incorrect, so "ocamlfind ocamlopt" did not work 49 | * [Compilation] file date_sig.mli, time_sig.mli and calendar_sig.mli was not 50 | properly linked 51 | 52 | version 2.01.1, 2009-02-23: 53 | =========================== 54 | o [Date] add a missing coercion rule for months 55 | (e.g. "Date.make 2008 18 1" is now equal to "Date.make 2009 6 1") 56 | * [Date] bug fixed in date arithmetic operations due to the missing above 57 | feature 58 | 59 | version 2.01, 2009-01-26: 60 | ========================= 61 | o [Printer] new formats available for printers and parsers 62 | - %C century: as %Y without the two last digits 63 | - %F replace %i which is now deprecated 64 | - %P am or pm 65 | - %R shortcut for %H:%M 66 | - %s number of seconds since 1970/1/1 67 | - %z time zone in the form +hhmm (from Warren Harris' suggestion) 68 | - %:z time zone in the form +hh:mm (from Warren Harris' suggestion) 69 | - %::z time zone in the form +hh:mm:ss (from Warren Harris' suggestion) 70 | - %:::z time zone in the form +hh (from Warren Harris' suggestion) 71 | o [Printer] new paddings available for printers 72 | - 0 (zero): pad fields with zeroes like by default 73 | - ^: use uppercase if possible 74 | o [Compilation] calendarLib.cma and calendarLib.cmxa are now installed 75 | (Janne Hellsten and Guillaume Yziquel's suggestion) 76 | * [Tests] test suite now uses Utils.Float.equal if required 77 | (patch of Richard Jones) 78 | * [Compilation] small bug fixed in make install 79 | * [Compilation] support of win64 (patch of David Allsopp) 80 | 81 | version 2.0.4, 2008-07-07: 82 | ========================== 83 | o [Printer] support of "%w" and "%V" in parsers of date from string 84 | * [Printer] bug fixed with "%j" 85 | 86 | version 2.0.3, 2008-05-22: 87 | ========================== 88 | * [Compilation] module Period was not properly linked 89 | 90 | version 2.0.2, 2008-03-17: 91 | ========================== 92 | * [Compilation] Windows build problems fixed (patch of David Allsopp) 93 | 94 | version 2.0.1, 2008-02-22: 95 | ========================== 96 | * [Printer] bug fixed in printers which displayed "Mars" (instead of "March") 97 | * [Printer] bug fixed in printers when %p cannot be parsed 98 | (error message was bad) (patch of Yaron Minski) 99 | * [Compilation] bug fixed in "make install" (patch of Sean Seefried) 100 | 101 | version 2.0, 2008-02-08: 102 | ======================== 103 | o! [License] license changes from LGPLv2 to LGPLv2.1 104 | (from a suggestion of Hezekiah M. Carty) 105 | o! [Compilation] use -pack: all modules of the library are packed inside a 106 | single module CalendarLib (calendar now requires ocaml >= 3.09.1) 107 | o new modules Time_sig, Date_sig and Calendar_sig 108 | o new module Ftime (time implementation in which seconds are floats) 109 | (Hezekiah M. Carty's suggestion) 110 | o new module Calendar_builder (generic calendar implementation) 111 | o new module Fcalendar (calendar implementation using Ftime) 112 | o new module Calendar.Precise (calendar with a best precision) 113 | o hash functions are provided 114 | o [Printer] new modules Printer.Ftime and Printer.Fcalendar 115 | o [Printer] modules Printer.Date, Printer.Time and Printer.Calendar 116 | respectively replace Printer.DatePrinter, Printer.TimePrinter and 117 | Printer.CalendarPrinter. These last modules still exist but are deprecated. 118 | o [Time_Zone] new function Time_Zone.on 119 | o [Date] new function Date.from_day_of_year (Hezekiah M. Carty's suggestion) 120 | o [Date] new function Date.is_valid_date (Richard Jones' suggestion) 121 | o new module Utils 122 | o new module Version (information about version of calendar) 123 | o [Documentation] add tags @example, @raise and @see in the API documentation 124 | 125 | version 1.10, 2007-05-14: 126 | ========================= 127 | o [Printer] "from_fstring" in printers recognizes more formats. 128 | (Sean Seefried's suggestion) 129 | o [Printer] add Printer.set_word_regexp 130 | 131 | version 1.09.6, 2006-07-07: 132 | =========================== 133 | * [Date] bug fixed in Date.to_business 134 | (on some dates in the last days of january) 135 | 136 | version 1.09.5, 2006-05-26: 137 | =========================== 138 | * [Date] bug fixed in Date.nth_weekday_of_month 139 | 140 | version 1.09.4, 2006-02-13: 141 | =========================== 142 | o [Time_Zone] add Time_Zone.is_dst and Time_Zone.hour_of_dst 143 | (Daniel Peng's suggestion) 144 | * [Printer] bug fixed in printers with %I, %l, %p and %r 145 | (patch of Jerry Charumilind) 146 | * [Time_Zone] bug fixed when checking bounds in Time_Zone (patch of Daniel Peng) 147 | 148 | version 1.09.3, 2005-01-17: 149 | =========================== 150 | * [Date] bug fixed in Date.to_business 151 | 152 | version 1.09.2, 2004-12-15: 153 | =========================== 154 | * [Date] bug fixed in Date.from_unixfloat and Date.from_unixtm with 155 | time zones <> UTC 156 | 157 | version 1.09.1, 2004-11-17: 158 | =========================== 159 | o [Documentation] add tag @since in the API documentation 160 | * [Calendar] bug fixed in Calendar.to/from_unixfloat with time zones <> UTC 161 | * [Compilation] META file is now writable 162 | 163 | version 1.09.0, 2004-11-13: 164 | =========================== 165 | o [Date] add Date.to_business and Date.from_business (Richard Jone's suggestion) 166 | o [Date] add the optional parameter ?month to Date.days_in_year 167 | (Richard Jones' suggestion) 168 | o [Date] add Date.nth_weekday_of_month (Richard Jones' suggestion) 169 | o [Date] Date: add some Christian dates (Richard Jones' suggestion) 170 | o [Date] add Date.Period.ymd and Calendar.Period.ymds 171 | o [Printer] add the format string %i corresponding to the ISO-8601 notation 172 | o add "equal" in all the modules 173 | *! [Printer] ISO-8601 notation is now the default format 174 | * [Calendar.Period] bug fixed with negative period 175 | * [Calendar] bug fixed in Calendar.to/from_unixfloat and Date.to/from_unixfloat 176 | * [Date] bug fixed in Date.weeks_in_year 177 | 178 | version 1.08, 2004-05-18: 179 | ========================= 180 | o [Date] add "week_first_last" computing the first and last days of a week in a 181 | year 182 | 183 | version 1.07, 2004-03-22: 184 | ========================= 185 | o [Documentation] documentation of the API with ocamldoc 186 | * [Compilation] compile even if no ocaml native compiler is available 187 | (from a patch of Stefano Zacchiroli) 188 | 189 | version 1.06, 2003-12-05: 190 | ========================= 191 | o [Compilation] improved "make install" 192 | * [Compilation] compile with an optimized compiler (ocamlopt.opt or ocamlc.opt) 193 | if possible 194 | 195 | version 1.05, 2003-09-18: 196 | ========================= 197 | o add module Printer (from a suggestion of Stefano Zacchiroli) 198 | o! remove to_string and from_string from Date, Time and Calendar 199 | (replaced by functions of Printer) 200 | o Str library is no longer necessary 201 | o add labelled version of make in Date, Time and Calendar 202 | 203 | version 1.04, 2003-08-31: 204 | ========================= 205 | o [Period] add getters in Time.Period, Date.Period and Calendar.Period 206 | (from a suggestion of Christoph Bauer) 207 | 208 | version 1.03, 2003-08-25: 209 | ========================= 210 | o [Calendar] add "to_time" in Calendar (Julien Forest's suggestion) 211 | 212 | version 1.02, 2003-08-18: 213 | ========================= 214 | * [Compilation] bug fixed in configure.in (calendar now works with 215 | caml version > 3.06) 216 | 217 | version 1.01, 2003-07-16: 218 | ========================= 219 | o add to_unixtm, from_unixtm, to_unixfloat and from_unixfloat in 220 | Date and Calendar 221 | *! change "minut" by "minute" 222 | *! change "egal" by "equal" 223 | *! change "GMT" by "UTC" 224 | 225 | (Thank's to Eric C. Cooper for those suggestions) 226 | 227 | version 1.0, 2003-07-11: 228 | ======================== 229 | o first release 230 | -------------------------------------------------------------------------------- /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 | Printf.printf "Tests of Date:\n";; 24 | 25 | open CalendarLib;; 26 | open Date;; 27 | include Gen_test;; 28 | reset ();; 29 | 30 | test_exn (lazy (make (-4713) 1 1)) "make (-4713) 1 1";; 31 | test_exn (lazy (make 3268 1 23)) "make 3268 1 23";; 32 | test_exn (lazy (make 1582 10 5)) "make 1582 10 10";; 33 | test (compare (make 2003 2 29) (make 2003 3 1) = 0) "2003-2-29 = 2003-3-1";; 34 | let d = make 2003 12 31;; 35 | test (next d `Month = make 2004 1 31) "2003-12-31 + 1 mois";; 36 | test (add d (Period.month 2) = make 2004 3 2) "2003-12-31 + 2 mois";; 37 | test (add (make 2008 12 31) (Period.month 6) = make 2009 7 1) 38 | "2008-12-31 + 6 mois";; 39 | test (rem (make 2008 6 2) (Period.month 12) = make 2007 6 2) 40 | "2008-6-2 - 12 mois";; 41 | test (rem (make 2007 2 30) (Period.month 4) = make 2006 11 2) 42 | "2008-2-30 - 4 mois";; 43 | test (make 2007 (-38) 30 = make 2003 10 30) 44 | "2007-(-38)-30 - 2003 10 30";; 45 | test (rem (make 2007 2 30) (Period.month 40) = make 2003 11 2) 46 | "2008-2-30 - 40 mois";; 47 | let d2 = make (-3000) 1 1;; 48 | test (rem d (sub d d2) = d2) "rem x (sub x y) = y";; 49 | test (Period.ymd (precise_sub (make 2010 10 5) (make 2010 6 2)) = (0, 4, 3)) 50 | "precise_sub 2010-10-5 2010-6-2";; 51 | test (Period.ymd (precise_sub (make 2010 10 5) (make 2010 6 5)) = (0, 4, 0)) 52 | "precise_sub 2010-10-5 2010-6-2";; 53 | test (Period.ymd (precise_sub (make 2010 10 5) (make 2010 6 6)) = (0, 3, 29)) 54 | "precise_sub 2010-10-5 2010-6-6";; 55 | test (Period.ymd (precise_sub (make 2010 10 5) (make 2010 6 4)) = (0, 4, 1)) 56 | "precise_sub 2010-10-5 2010-6-4";; 57 | test (Period.ymd (precise_sub (make 2010 1 1) (make 2000 1 1)) = (10, 0, 0)) 58 | "precise_sub 2010-1-1 2000-1-1";; 59 | test (from_jd 0 = make (-4712) 1 1) "from_jd 0 = 4713 BC-1-1";; 60 | test (to_jd (from_jd 12345) = 12345) "to_jd (from_jd x) = x";; 61 | test (from_mjd 0 = make 1858 11 17) "from_mjd 0 = 1858-11-17";; 62 | test (to_mjd (from_mjd 12345) = 12345) "to_mjd (from_mjd x) = x";; 63 | test (is_leap_day (make 2000 2 24)) "2000-2-24 leap day";; 64 | test (not (is_leap_day (make 2000 2 25))) "2000-2-25 not leap day";; 65 | test (is_gregorian (make 1600 1 1)) "1600-1-1 gregorian";; 66 | test (not (is_gregorian (make 1400 1 1))) "1400-1-1 not gregorian";; 67 | test (is_julian (make 1582 1 1)) "1582-1-1 julian";; 68 | test (not (is_julian (make 1583 1 1))) "1583-1-1 not julian";; 69 | test (int_of_day Mon = 1) "Monday = 1";; 70 | test (int_of_day Sun = 7) "Sunday = 7";; 71 | test (day_of_int 1 = Mon) "1 = Monday";; 72 | test (day_of_int 7 = Sun) "1 = Monday";; 73 | test (int_of_month Jan = 1) "January = 1";; 74 | test (month_of_int 12 = Dec) "12 = December";; 75 | test (not (is_leap_year 1999)) "1999 not leap year";; 76 | test (not (is_leap_year 1800)) "1800 not leap year";; 77 | test (is_leap_year 1996) "1996 leap year";; 78 | test (is_leap_year 1600) "1600 leap year";; 79 | test (same_calendar 1956 1900) "same calendar 1956 1900";; 80 | test (same_calendar 2001 2013) "same calendar 2001 2013";; 81 | test (same_calendar 1998 2009) "same calendar 1998 2009";; 82 | test (same_calendar 2003 2025) "same calendar 2003 2025";; 83 | test (days_in_year 2000 = 366) "days_in_year 2000";; 84 | test (days_in_year 1900 = 365) "days_in_year 1900";; 85 | test (days_in_year ~month:Jan 2000 = 31) "days_in_year Jan 2000";; 86 | test (days_in_year ~month:Feb 2000 = 60) "days_in_year Feb 2000";; 87 | test (days_in_year ~month:Jan 2000 = 31) "days_in_year Jan 2000";; 88 | test (days_in_year ~month:Mar 1900 = 90) "days_in_year Mar 1900";; 89 | test (weeks_in_year 2000 = 52) "weeks_in_year 2000";; 90 | test (weeks_in_year 2020 = 53) "weeks_in_year 2020";; 91 | test (weeks_in_year 1991 = 52) "weeks_in_year 1991";; 92 | test (weeks_in_year 1999 = 52) "weeks_in_year 1999";; 93 | test (days_in_month (make 2000 2 18) = 29) "days_in_month 2000-2-18";; 94 | test (days_in_month (make_year_month 2000 2) = 29) "days_in_month 2000-2";; 95 | (* untypable: *) 96 | (* test (days_in_month ((make_year 2000 :> [ `Year | `Month ] Date.date)) = 29) "days_in_month 2000-2";; *) 97 | test (days_in_year 1900 = 365) "days_in_year 1900";; 98 | test (century 2000 = 20) "century 2000";; 99 | test (century 2001 = 21) "century 2001";; 100 | test (millenium 2000 = 2) "millenium 2000";; 101 | test (millenium 2001 = 3) "millenium 2001";; 102 | test (year (make_year_month 2000 3) = 2000) "year 2000-3";; 103 | test (year (make_year 2000) = 2000) "year 2000";; 104 | test (month (make 2000 4 23) = Apr) "year 2000-4-23";; 105 | test (month (make_year_month 2000 3) = Mar) "year 2000-3";; 106 | (* untypable: *) 107 | (*test (month (make_year 2000) = Mar) "year 2000";;*) 108 | test (easter 2003 = make 2003 4 20) "Paques 2003";; 109 | test (Period.nb_days (Period.make 0 0 6) = 6) "Period.nb_days ok";; 110 | test (Period.safe_nb_days (Period.week 3) = 21) "Period.safe_nb_days ok";; 111 | test_exn (lazy (Period.nb_days (Period.make 1 0 0))) "Period.nb_days ko";; 112 | test (week_first_last 21 2004 = (make 2004 5 17, make 2004 5 23)) 113 | "week_beggining_end";; 114 | test (Period.ymd (Period.make 1 2 3) = (1, 2, 3)) "Period.ymd";; 115 | test (nth_weekday_of_month 2004 Oct Thu 4 = make 2004 10 28) 116 | "nth_weekday_of_month";; 117 | test (nth_weekday_of_month 2006 Mar Fri 3 = make 2006 3 17) 118 | "nth_weekday_of_month";; 119 | test (equal (from_day_of_year 2008 39) (make 2008 2 8)) 120 | "from_day_of_year";; 121 | test (is_valid_date 2008 2 8) "is_valid_date";; 122 | test (not (is_valid_date 2008 2 30)) "not is_valid_date";; 123 | 124 | (* Unix *) 125 | Time_Zone.change Time_Zone.UTC;; 126 | test (to_unixfloat (make 1970 1 1) = 0.) "to_unixfloat 1 Jan 1970";; 127 | test (from_unixfloat 0. = make 1970 1 1) "from_unixfloat 0.";; 128 | test (to_unixfloat (make 2004 11 13) = 1100304000.) "to_unixfloat";; 129 | test (from_unixfloat 1100304000. = make 2004 11 13) "from_unixfloat";; 130 | test (from_unixtm (to_unixtm (make 2003 7 16)) = make 2003 7 16) 131 | "from_unixtm to_unixtm = id";; 132 | Time_Zone.change (Time_Zone.UTC_Plus (-1));; 133 | test (from_unixfloat 0. = make 1969 12 31) "from_unixfloat 0. (dec-)";; 134 | test (from_unixtm { Unix.tm_sec = 0; tm_min = 0; tm_hour = 0; tm_mday = 1; 135 | tm_mon = 0; tm_year = 70; tm_wday = 4; tm_yday = 0; 136 | tm_isdst = false } = make 1969 12 31) 137 | "from_unixtm (dec-)";; 138 | Time_Zone.change (Time_Zone.UTC_Plus 1);; 139 | test (from_unixfloat 1100390390. = make 2004 11 14) "from_unixfloat (dec+)";; 140 | test (from_unixtm { Unix.tm_sec = 0; tm_min = 0; tm_hour = 0; tm_mday = 14; 141 | tm_mon = 10; tm_year = 104; tm_wday = 0; tm_yday = 318; 142 | tm_isdst = false } = make 2004 11 14) 143 | "from_unixtm (dec+)";; 144 | test (from_unixtm (to_unixtm (make 2003 7 16)) = make 2003 7 16) 145 | "from_unixtm to_unixtm = id";; 146 | 147 | (* to_business *) 148 | test (to_business (make 2003 1 1) = (2003, 1, Wed)) "to_business 1";; 149 | test (to_business (make 2003 12 31) = (2004, 1, Wed)) "to_business 2";; 150 | test (to_business (make 2002 12 31) = (2003, 1, Tue)) "to_business 3";; 151 | test (to_business (make 2005 1 1) = (2004, 53, Sat)) "to_business 4";; 152 | test (to_business (make 2004 12 31) = (2004, 53, Fri)) "to_business 5";; 153 | test (to_business (make 2006 1 1) = (2005, 52, Sun)) "to_business 6";; 154 | test (to_business (make 2005 1 17) = (2005, 3, Mon)) "to_business 7";; 155 | test (to_business (make 2006 1 31) = (2006, 5, Tue)) "to_business 8";; 156 | test (to_business (make 2005 1 31) = (2005, 5, Mon)) "to_business 9";; 157 | (* from_business *) 158 | test (from_business 2003 1 Wed = make 2003 1 1) "from_business 1";; 159 | test (from_business 2004 1 Wed = make 2003 12 31) "from_business 2";; 160 | test (from_business 2003 1 Tue = make 2002 12 31) "from_business 3";; 161 | test (from_business 2004 53 Sat = make 2005 1 1) "from_business 4";; 162 | test (from_business 2004 53 Fri = make 2004 12 31) "from_business 5";; 163 | test (from_business 2005 52 Sun = make 2006 1 1) "from_business 6";; 164 | test (from_business 2005 3 Mon = make 2005 1 17) "from_business 7";; 165 | test (from_business 2006 5 Tue = make 2006 1 31) "from_business 8";; 166 | test (from_business 2005 5 Mon = make 2005 1 31) "from_business 9";; 167 | test_exn (lazy (from_business 2005 0 Sun)) "from_business_bad 1";; 168 | test_exn (lazy (from_business 2005 53 Sun)) "from_business_bad 2";; 169 | 170 | let ok = nb_ok ();; 171 | let bug = nb_bug ();; 172 | Printf.printf "tests ok : %d; tests ko : %d\n" ok bug;; 173 | flush stdout;; 174 | -------------------------------------------------------------------------------- /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/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: 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/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 hash = Utils.Int.hash 69 | 70 | (* Constructors. *) 71 | 72 | let lt (d1 : int * int * int) (d2 : int * int * int) = 73 | Pervasives.compare d1 d2 < 0 74 | 75 | (* [date_ok] returns [true] is the date belongs to the Julian period; 76 | [false] otherwise. *) 77 | let date_ok y m d = lt (-4713, 12, 31) (y, m, d) && lt (y, m, d) (3268, 1, 23) 78 | 79 | (* Coerce month to the interval ]-oo; 12]. 80 | Note that the used algorithm of [make] does not require any coercion for 81 | negative months *) 82 | let coerce_month y m = 83 | if m < 0 then 84 | y, m 85 | (* (* the below commented lines coerce [m] inside the interval [1;12] 86 | instead of ]-oo;12]*) 87 | let diff_y = (m + 1) / 12 - 1 in 88 | y + diff_y, - 12 * diff_y + m*) 89 | else 90 | let pred_m = pred m in 91 | y + pred_m / 12, pred_m mod 12 + 1 92 | 93 | let make y m d = 94 | let y, m = coerce_month y m in 95 | if date_ok y m d then 96 | let a = (14 - m) / 12 in 97 | let y' = y + 4800 - a in 98 | let m' = m + 12 * a - 3 in 99 | if lt (1582, 10, 14) (y, m, d) then 100 | (* Gregorian calendar *) 101 | d + (153 * m' + 2) / 5 + y' * 365 + y' / 4 - y' / 100 + y' / 400 - 32045 102 | else if lt (y, m, d) (1582, 10, 5) then 103 | (* Julian calendar *) 104 | d + (153 * m' + 2) / 5 + y' * 365 + y' / 4 - 32083 105 | else 106 | raise Undefined 107 | else 108 | raise Out_of_bounds 109 | 110 | let lmake ~year ?(month = 1) ?(day = 1) () = make year month day 111 | 112 | let make_year y = make y 1 1 113 | let make_year_month y m = make y m 1 114 | 115 | let current_day day gmt_hour = 116 | let hour = Time_Zone.from_gmt () + gmt_hour in 117 | (* change the day according to the time zone *) 118 | if hour < 0 then begin 119 | assert (hour > - 13); 120 | day - 1 121 | end else if hour >= 24 then begin 122 | assert (hour < 36); 123 | day + 1 124 | end else 125 | day 126 | 127 | let jan_1_1970 = 2440588 128 | 129 | let from_unixfloat x = 130 | let d = int_of_float (x /. 86400.) + jan_1_1970 in 131 | current_day d (Unix.gmtime x).Unix.tm_hour 132 | 133 | let from_day_of_year y d = make y 1 d 134 | 135 | let today () = from_unixfloat (Unix.time ()) 136 | 137 | let from_jd n = n 138 | let to_jd d = d 139 | 140 | let from_mjd x = x + 2400001 141 | let to_mjd d = d - 2400001 142 | 143 | (*S Useful operations. *) 144 | 145 | let is_leap_year y = 146 | if y > 1582 then (* Gregorian calendar *) 147 | y mod 4 = 0 && (y mod 100 <> 0 || y mod 400 = 0) 148 | else (* Julian calendar *) 149 | if y > (- 45) && y <= (- 8) then 150 | (* every year divisible by 3 is a leap year between 45 BC and 9 BC *) 151 | y mod 3 = 0 152 | else if y <= (- 45) || y >= 8 then y mod 4 = 0 153 | else (* no leap year between 8 BC and 7 AD *) false 154 | 155 | (*S Boolean operations on dates. *) 156 | 157 | let is_julian d = d < 2299161 158 | let is_gregorian d = d >= 2299161 159 | 160 | (*S Getters. *) 161 | 162 | (* [a] and [e] are auxiliary functions for [day_of_month], [month] 163 | and [year]. *) 164 | let a d = d + 32044 165 | 166 | let e d = 167 | let c = 168 | if is_julian d then d + 32082 169 | else let a = a d in a - (((4 * a + 3) / 146097) * 146097) / 4 170 | in c - (1461 * ((4 * c + 3) / 1461)) / 4 171 | 172 | let day_of_month d = 173 | let e = e d in 174 | let m = (5 * e + 2) / 153 in 175 | e - (153 * m + 2) / 5 + 1 176 | 177 | let int_month d = let m = (5 * e d + 2) / 153 in m + 3 - 12 * (m / 10) 178 | 179 | let month d = month_of_int (int_month d - 1) 180 | 181 | let year d = 182 | let b, c = 183 | if is_julian d then 0, d + 32082 184 | else 185 | let a = a d in 186 | let b = (4 * a + 3) / 146097 in 187 | b, a - (b * 146097) / 4 in 188 | let d = (4 * c + 3) / 1461 in 189 | let e = c - (1461 * d) / 4 in 190 | b * 100 + d - 4800 + ((5 * e + 2) / 153) / 10 191 | 192 | let int_day_of_week d = (d + 1) mod 7 193 | 194 | let day_of_week d = day_of_int (int_day_of_week d) 195 | 196 | let day_of_year d = d - make (year d - 1) 12 31 197 | 198 | (* [week] implements an algorithm coming from Stefan Potthast. *) 199 | let week d = 200 | let d4 = (d + 31741 - (d mod 7)) mod 146097 mod 36524 mod 1461 in 201 | let l = d4 / 1460 in 202 | (((d4 - l) mod 365) + l) / 7 + 1 203 | 204 | let days_in_month d = 205 | match month d with 206 | | Jan | Mar | May | Jul | Aug | Oct | Dec -> 31 207 | | Apr | Jun | Sep | Nov -> 30 208 | | Feb -> if is_leap_year (year d) then 29 else 28 209 | 210 | (* Boolean operation using some getters. *) 211 | let is_leap_day d = 212 | is_leap_year (year d) && month d = Feb && day_of_month d = 24 213 | 214 | let is_valid_date y m d = 215 | try 216 | let t = make y m d in 217 | year t = y && int_month t = m && day_of_month t = d 218 | with Out_of_bounds | Undefined -> 219 | false 220 | 221 | (*S Period. *) 222 | 223 | module Period = struct 224 | 225 | (* Cannot use an [int] : periods on months and years have not a constant 226 | number of days. 227 | For example, if we add a "one year" period [p] to the date 2000-3-12, 228 | [p] corresponds to 366 days (because 2000 is a leap year) and the 229 | resulting date is 2001-3-12 (yep, one year later). But if we add [p] to 230 | the date 1999-3-12, [p] corresponds to 365 days and the resulting date is 231 | 2000-3-12 (yep, one year later too). *) 232 | type +'a period = { m (* month *) : int; d (* day *) : int } 233 | constraint 'a = [< field ] 234 | 235 | type +'a p = 'a period 236 | type t = field period 237 | 238 | let empty = { m = 0; d = 0 } 239 | 240 | let make y m d = { m = 12 * y + m; d = d } 241 | let lmake ?(year = 0) ?(month = 0) ?(day = 0) () = make year month day 242 | 243 | let day n = { empty with d = n } 244 | let week n = { empty with d = 7 * n } 245 | let month n = { empty with m = n } 246 | let year n = { empty with m = 12 * n } 247 | 248 | let add x y = { m = x.m + y.m; d = x.d + y.d } 249 | let sub x y = { m = x.m - y.m; d = x.d - y.d } 250 | let opp x = { m = - x.m; d = - x.d } 251 | 252 | (* exactly equivalent to [Pervasives.compare] but more flexible typing *) 253 | let compare x y = 254 | let n = Pervasives.compare x.m y.m in 255 | if n = 0 then Pervasives.compare x.d y.d else n 256 | let equal x y = compare x y = 0 257 | let hash = Hashtbl.hash 258 | 259 | exception Not_computable 260 | 261 | let nb_days p = if p.m <> 0 then raise Not_computable else p.d 262 | 263 | let safe_nb_days p = p.d 264 | 265 | let ymd p = p.m / 12, p.m mod 12, p.d 266 | 267 | end 268 | 269 | (*S Arithmetic operations on dates and periods. *) 270 | 271 | let add d p = 272 | let y,m,day = Period.ymd p in 273 | make 274 | (year d + y) 275 | (int_month d + m) 276 | (day_of_month d + day) 277 | 278 | let sub x y = { Period.empty with Period.d = x - y } 279 | 280 | let precise_sub y x = 281 | let rec aux m = 282 | if x + 31 * m < y then 283 | aux (m + 1) 284 | else 285 | let y' = add x (Period.month m) in 286 | let d = y - y' in 287 | if d < 0 then 288 | let m = m - 1 in 289 | (* don't use [y'] below: [m] changes *) 290 | m, d + days_in_month (add x (Period.month m)) 291 | else if d >= days_in_month y' then 292 | aux (m + 1) 293 | else 294 | m, d 295 | in 296 | let m, d = aux ((y - x) / 31) in 297 | { Period.m = m; d = d } 298 | 299 | let rem d p = add d (Period.opp p) 300 | 301 | let next d = function 302 | | `Year -> add d (Period.year 1) 303 | | `Month -> add d (Period.month 1) 304 | | `Week -> add d (Period.day 7) 305 | | `Day -> add d (Period.day 1) 306 | 307 | let prev d = function 308 | | `Year -> add d (Period.year (- 1)) 309 | | `Month -> add d (Period.month (- 1)) 310 | | `Week -> add d (Period.day (- 7)) 311 | | `Day -> add d (Period.day (- 1)) 312 | 313 | (*S Operations on years. *) 314 | 315 | let same_calendar y1 y2 = 316 | let d = y1 - y2 in 317 | let aux = 318 | if is_leap_year y1 then true 319 | else if is_leap_year (y1 - 1) then d mod 6 = 0 || d mod 17 = 0 320 | else if is_leap_year (y1 - 2) then d mod 11 = 0 || d mod 17 = 0 321 | else if is_leap_year (y1 - 3) then d mod 11 = 0 322 | else false 323 | in d mod 28 = 0 || aux 324 | 325 | let days_in_year = 326 | let days = [| 31; 59; 90; 120; 151; 181; 212; 243; 273; 304; 334; 365 |] in 327 | fun ?(month=Dec) y -> 328 | let m = int_of_month month in 329 | let res = days.(m) in 330 | if is_leap_year y && m > 0 then res + 1 else res 331 | 332 | let weeks_in_year y = 333 | let first_day = day_of_week (make y 1 1) in 334 | match first_day with 335 | | Thu -> 53 336 | | Wed -> if is_leap_year y then 53 else 52 337 | | _ -> 52 338 | 339 | let week_first_last w y = 340 | let d = make y 1 1 in 341 | let d = d - d mod 7 in 342 | let b = d + 7 * (w - 1) in 343 | b, 6 + b 344 | 345 | let nth_weekday_of_month y m d n = 346 | let first = make y (int_of_month m + 1) 1 in 347 | let gap = 348 | let diff = int_of_day d - int_day_of_week first in 349 | if diff >= 0 then diff - 7 else diff 350 | in 351 | first + 7 * n + gap 352 | 353 | let century y = if y mod 100 = 0 then y / 100 else y / 100 + 1 354 | 355 | let millenium y = if y mod 1000 = 0 then y / 1000 else y / 1000 + 1 356 | 357 | let solar_number y = (y + 8) mod 28 + 1 358 | 359 | let indiction y = (y + 2) mod 15 + 1 360 | 361 | let golden_number y = y mod 19 + 1 362 | 363 | let epact y = 364 | let julian_epact = (11 * (golden_number y - 1)) mod 30 in 365 | if y <= 1582 then julian_epact (* Julian calendar *) 366 | else (* Gregorian calendar *) 367 | let c = y / 100 + 1 (* century *) in 368 | (* 1900 belongs to the 20th century for this algorithm *) 369 | abs ((julian_epact - (3 * c) / 4 + (8 * c + 5) / 25 + 8) mod 30) 370 | 371 | (* [easter] implements the algorithm of Oudin (1940) *) 372 | let easter y = 373 | let g = y mod 19 in 374 | let i, j = 375 | if y <= 1582 then (* Julian calendar *) 376 | let i = (19 * g + 15) mod 30 in 377 | i, (y + y / 4 + i) mod 7 378 | else (* Gregorian calendar *) 379 | let c = y / 100 in 380 | let h = (c - c / 4 - (8 * c + 13) / 25 + 19 * g + 15) mod 30 in 381 | let i = h - (h / 28) * (1 - (h / 28) * (29 / (h + 1)) * ((21 - g) / 11)) 382 | in i, (y + y / 4 + i + 2 - c + c / 4) mod 7 383 | in 384 | let l = i - j in 385 | let m = 3 + (l + 40) / 44 in 386 | make y m (l + 28 - 31 * (m / 4)) 387 | 388 | let carnaval y = easter y - 48 389 | let mardi_gras y = easter y - 47 390 | let ash y = easter y - 46 391 | let palm y = easter y - 7 392 | let easter_friday y = easter y - 2 393 | let easter_saturday y = easter y - 1 394 | let easter_monday y = easter y + 1 395 | let ascension y = easter y + 39 396 | let withsunday y = easter y + 49 397 | let withmonday y = easter y + 50 398 | let corpus_christi y = easter y + 60 399 | 400 | (*S Exported Coercions. *) 401 | 402 | let from_unixtm x = 403 | let d = (* current day at GMT *) 404 | make (x.Unix.tm_year + 1900) (x.Unix.tm_mon + 1) x.Unix.tm_mday 405 | in 406 | current_day d x.Unix.tm_hour 407 | 408 | let to_unixtm d = 409 | { Unix.tm_sec = 0; Unix.tm_min = 0; Unix.tm_hour = 0; 410 | Unix.tm_mday = day_of_month d; 411 | Unix.tm_mon = int_month d - 1; 412 | Unix.tm_year = year d - 1900; 413 | Unix.tm_wday = int_day_of_week d; 414 | Unix.tm_yday = day_of_year d - 1; 415 | Unix.tm_isdst = false } 416 | 417 | let to_unixfloat x = float_of_int (x - jan_1_1970) *. 86400. 418 | (* do not replace [*.] by [*]: the result is bigger than [max_int] ! *) 419 | 420 | let to_business d = 421 | let w = week d in 422 | let y = 423 | let y = year d in 424 | match int_month d with 425 | | 1 -> let x = y - 1 in if w = weeks_in_year x then x else y 426 | | 12 -> if w = 1 then y + 1 else y 427 | | _ -> y 428 | in 429 | y, w, day_of_week d 430 | 431 | let int_of_day d = let n = int_of_day d in if n = 0 then 7 else n 432 | (* Used by [from_business] *) 433 | 434 | let from_business y w d = 435 | if w < 1 || w > weeks_in_year y then invalid_arg "from_business: bad week"; 436 | let first = 437 | try make y 1 1 438 | with Out_of_bounds | Undefined -> invalid_arg "from_business: bad date" 439 | in 440 | let first_day = int_day_of_week first in 441 | let w = if first_day > 4 then w else w - 1 in 442 | first + w * 7 + int_of_day d - first_day 443 | 444 | (* These coercions redefine those defined at the beginning of the module. 445 | They respect ISO-8601. *) 446 | 447 | let int_of_day = int_of_day 448 | 449 | let day_of_int n = 450 | if n > 0 && n < 7 then day_of_int n 451 | else if n = 7 then day_of_int 0 452 | else invalid_arg "Not a day" 453 | 454 | let int_of_month m = int_of_month m + 1 455 | 456 | let month_of_int n = 457 | if n > 0 && n < 13 then month_of_int (n - 1) else invalid_arg "Not a month" 458 | -------------------------------------------------------------------------------- /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 | --------------------------------------------------------------------------------