Commits

camlspotter committed 016696c

date

Comments (0)

Files changed (3)

+(** Date *)
+  
+open Base
+
+module Year = struct
+  (* leap year of Gregorian calendar, which is introduced
+     by Pope Gregory XIII, after whom the calendar was named, 
+     by a decree signed on 24 February 1582.
+
+     The next day of 1582/10/4(Thu) in Julian calendar
+     is 1582/10/15(Fri) in Gregorian calendar
+  *)
+  let is_leap n = 
+    if n mod 400 = 0 then true
+    else if n mod 100 = 0 then false
+    else if n mod 4 = 0 then true
+    else false
+
+  let days_of_year n = if is_leap n then 366 else 365
+end
+
+module Date = struct
+  type t = Date_lexer.t = {
+    year : int;  (* 1998 *)
+    month : int; (* 1-12 *)
+    day : int
+  }
+
+  let to_string t = Printf.sprintf "%04d-%02d-%02d" t.year t.month t.day
+  
+  exception Parse_error
+  
+  let of_string_exn s = 
+    try 
+      let lexbuf = Lexing.from_string s in
+      let res = Date_lexer.parse_date lexbuf in
+      (* There may be some garbage in lexbuf *)
+      if String.length s <> Lexing.lexeme_end lexbuf then raise Parse_error;
+      res
+    with _ -> raise Parse_error
+  
+  let of_string s = Result.catch_exn & fun () -> of_string_exn s
+  
+  let random_with_invalid () =
+    { year = Random.int 200 + 1900;
+      month = Random.int 12 + 1;
+      day = Random.int 31 + 1 }
+
+  let days_of_month_in_non_leap_year = 
+    (*  1;  2;  3;  4;  5;  6;  7;  8;  9; 10; 11; 12 *)
+    [| 31; 28; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 |]
+
+  let days_of_month_in_leap_year = 
+    (*  1;  2;  3;  4;  5;  6;  7;  8;  9; 10; 11; 12 *)
+    [| 31; 29; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 |]
+
+  let make_day_shifts days_of_month =
+    let a = Array.create 12 0 in
+    let rec make sum = function
+      | 12 -> ()
+      | n -> 
+          a.(n) <- sum;
+          make (sum + days_of_month.(n)) (n+1)
+    in
+    make 0 0;
+    a
+
+  let day_shifts_in_non_leap_year = make_day_shifts days_of_month_in_non_leap_year
+  let day_shifts_in_leap_year = make_day_shifts days_of_month_in_leap_year
+
+  (* day of the year 1--365 or 366. Named from tm_yday *)
+  let yday t =
+    let day_shifts = 
+      if Year.is_leap t.year then day_shifts_in_leap_year
+      else day_shifts_in_non_leap_year
+    in
+    day_shifts.(t.month-1) + t.day
+
+  let diff t1 t2 =
+    let diff' tgt tlt =
+      let rec sum y = 
+        if y = tgt.year then yday tgt
+        else Year.days_of_year y + sum (y+1)
+      in
+      sum (tlt.year + 1) + Year.days_of_year tlt.year - yday tlt
+    in
+    match compare t1.year t2.year with
+    | 0 -> yday t1 - yday t2
+    | 1 -> diff' t1 t2
+    | -1 -> - (diff' t2 t1)
+    | _ -> assert false
+
+  TEST "to_string" =
+    "2000-04-01" = to_string { year = 2000; month = 4; day = 1 }
+  
+  TEST "of_string" =
+    of_string "2000-04-01" = `Ok { year = 2000; month = 4; day = 1 }
+  
+  TEST "of_string" =
+    match of_string "2000-04-01-" with
+    | `Ok _ -> false
+    | `Error _ -> true
+
+  TEST "diff" = 
+    diff 
+      (Result.from_Ok (fun _ -> assert false) & of_string "2013-06-01")
+      (Result.from_Ok (fun _ -> assert false) & of_string "2012-01-31") 
+    = 366 - 31 + 31 + 28 + 31 + 30 + 31 + 1
+end
+
+module Unix0 = Unix
+
+module Unix = struct
+  open Unix
+  open Date
+
+  let to_tm t = 
+    assert (t.year >= 1970);
+    assert (t.year < 2038);
+    let tm = 
+      { tm_sec   = 0;
+        tm_min   = 0;
+        tm_hour  = 0;
+        tm_mday  = t.day;
+        tm_mon   = t.month - 1;
+        tm_year  = t.year - 1900;
+        tm_wday  = 0; (* unspecified *)
+        tm_yday  = 0; (* unspecified *)
+        tm_isdst = false }
+    in
+    let f, tm' = Unix.mktime tm in
+    let invalid = 
+      not (tm'.tm_mday = tm.tm_mday
+        && tm'.tm_mon  = tm.tm_mon
+        && tm'.tm_year = tm.tm_year)
+    in
+    f, tm', if invalid then `Invalid else `Ok
+  
+  let to_tm t = Option.catch_exn (fun () -> to_tm t) 
+
+  let of_tm tm = 
+    { year  = tm.tm_year + 1900;
+      month = tm.tm_mon + 1;
+      day   = tm.tm_mday }
+
+  (* CR jfuruse: Check the standard *)      
+  let string_of_tm tm = 
+    Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02d"
+      (tm.tm_year + 1900)
+      (tm.tm_mon + 1)
+      tm.tm_mday
+      tm.tm_hour
+      tm.tm_min
+      tm.tm_sec
+
+  TEST_UNIT "Date.Unix" = 
+    let open Unix in
+    let t = Result.from_Ok (fun _ -> assert false) & of_string "2000-04-01" in
+    let _, tm, inv = Option.from_Some & to_tm t in
+    assert ((tm.tm_year, tm.tm_mon, tm.tm_mday, inv) = (2000 - 1900, 4 - 1, 1, `Ok))
+
+end
+
+module Fat = struct
+
+  let int64_of_float f = 
+    let i = Int64.of_float f in
+    assert (Int64.to_float i = f);
+    i
+
+  type t = { date : Date.t;
+             epoch : float;
+             tm : Unix0.tm }
+
+  let to_string t = 
+    Printf.sprintf "{date = %s; epoch = %f; tm = %s}"
+      (Date.to_string t.date)
+      t.epoch
+      (Unix.string_of_tm t.tm)
+
+  let create date = 
+    match Unix.to_tm date with
+    | None -> `Error (`Invalid_date date)
+    | Some (epoch, tm, mal) ->
+        match mal with
+        | `Invalid -> `Error (`Invalid_date date)
+        | `Ok -> `Ok { date; epoch; tm }
+
+  let secs_of_day = 
+    let open Xint64 in
+    24L * 60L * 60L
+    
+  let diff t1 t2 = 
+    (* Pretty dirty rounding hack of local epochs which might be
+       calculated from historical different local time settings.
+       +-4hours are accepted.
+    *)
+    let open Xint64 in
+    let d = int64_of_float & t1.epoch -. t2.epoch in
+    let div = Int64.to_int & d / secs_of_day in
+    let rem = Int64.rem d secs_of_day in
+    let fixed_div = 
+      if -14400L <= rem && rem <= 14400L then div
+      else if rem >= 72000L then Pervasives.(+) div 1
+      else if rem <= -72000L then Pervasives.(-) div 1
+      else begin 
+        Format.eprintf "%s %s@." (to_string t1) (to_string t2);
+        assert false
+      end
+    in
+    fixed_div
+
+  let rec random () = 
+    let d = Date.random_with_invalid () in
+    match Unix.to_tm d with
+    | Some (f, tm, `Ok) -> { date = d; epoch = f; tm }
+    | Some (_, _, `Invalid) -> random ()
+    | None -> random ()
+
+  TEST_UNIT "random" =
+    for _i = 0 to 1000 do    
+      ignore (random ())
+    done
+
+  TEST_UNIT "diff" =
+    for _i = 0 to 100000 do    
+      let t1 = random () in
+      let t2 = random () in
+      let diff_date = Date.diff t1.date t2.date in
+      let diff_fat  = diff t1 t2 in
+      if diff_date <> diff_fat then begin
+        Format.eprintf "%s %s %d %d@."
+          (to_string t1) (to_string t2)
+          diff_date diff_fat;
+        assert false
+      end
+    done
+
+end
+
+let random () = (Fat.random ()).Fat.date
+
+include Date
+
+type date = Date.t
+
 (** Date *)
 
+module Year : sig 
+  val is_leap : int -> bool 
+  val days_of_year : int -> int 
+end
+
 type t = {
   year  : int;  (* 1998 *)
   month : int; (* 1-12 *)
   day   : int
 }
 
+type date = t
+
 val to_string : t -> string
 
 exception Parse_error
 val of_string_exn : string -> t
 val of_string : string -> [> (t, exn) Result.t ]
 
-val test : unit -> unit
+val yday : t -> int
+(** 1--365 or 366 *)
 
+val diff : t -> t -> int
+
+val random_with_invalid : unit -> t
+val random : unit -> t
+
+module Unix : sig
+  val to_tm : date -> (float * Unix.tm * [> `Invalid | `Ok ]) option
+  (** Performs Unix sys call, and normalize the date.
+      So it is a bit costy.
+
+      The last component indicates whether the input is invalid
+      (normalization was necessary) or not.
+      Since it uses Unix time, Year is only acceptable between 1970-2037.
+
+      Epoch is computed from the localtime. Be careful. 
+      For example, Singapore has very complex history of timezone.
+  *)
+  
+  val of_tm : Unix.tm -> t 
+
+  val string_of_tm : Unix.tm -> string
+end
+
+module Fat : sig
+  type t
+  val create : date -> [> (t,  [> `Invalid_date of date ]) Result.t ]
+  val random : unit -> t
+
+  val diff : t -> t -> int
+  (** Computed from Unix epoch. *)
+end
+
+
+

lib/date_lexer.mll

+{
+  (** Date *)
+  
+  type t = {
+    year : int;  (* 1998 *)
+    month : int; (* 1-12 *)
+    day : int
+  }
+
+}
+
+let digit = ['0'-'9']
+
+rule parse_date = parse
+  | (digit digit digit digit as year)
+    '-'
+    (digit digit as month)
+    '-'
+    (digit digit as day)
+    {
+      { year  = int_of_string year;
+        month = int_of_string month;
+        day   = int_of_string day 
+      }
+    }
+
+{
+}
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.