Source

spotlib / lib / temporal.ml

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
(** Date *)

(*
camlp4o -I ~/.opam/system/lib/pa_ounit/ pa_ounit_syntax.cma -pa-ounit-lib spotlib  temporal.ml
*)
  
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 Weekday = struct

  let to_string = function
    | 0 -> "Sun"
    | 1 -> "Mon"
    | 2 -> "Tue"
    | 3 -> "Wed"
    | 4 -> "Thu"
    | 5 -> "Fri"
    | 6 -> "Sat"
    | _ -> assert false

end

module Date = struct

  type t = Temporal_lexer.date = {
    year : int;  (* 1998 *)
    month : int; (* 1-12 *)
    day : int
  }

  type _t = t

  include Mtypes.Make_comparable(struct
    type t = _t
    let compare = compare
  end)

  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 = Temporal_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 days_of_month y = 
    if Year.is_leap y then days_of_month_in_leap_year 
    else days_of_month_in_non_leap_year

  let is_valid t = 
    if t.year < 1900 || t.year > 2100 then false
    else if t.month < 1 || t.month > 12 then false
    else
      let dom =(days_of_month t.year).(t.month-1) in
      if t.day < 1 || t.day > dom then false
      else true
 
  TEST "is_valid" =
    is_valid (Result.from_Ok (fun _ -> assert false) & of_string "2000-04-01")

  TEST "is_valid" =
    not & is_valid (Result.from_Ok (fun _ -> assert false) & of_string "2000-04-31")
  
  TEST "is_valid" =
    is_valid (Result.from_Ok (fun _ -> assert false) & of_string "2000-02-29")
  
  let random () =
    let year = Random.int 200 + 1900 in
    let month = Random.int 12 + 1 in
    let day = 
      let days = (days_of_month year).(month-1) in
      (* To check more bondary conditions, we have more 1 and 28,29,30,31 *)
      let d8 = Random.int 8 in
      match d8 with
      | 0 -> 1
      | 1 -> days
      | 2 -> days - 1
      | _ -> Random.int days + 1
    in
    { year; month; day }

      
  let date_1970_01_01 = { year = 1970; month = 1; day = 1 }
  let date_2038_01_01 = { year = 2038; month = 1; day = 1 }

  let rec random_2038 () =
    let d = random () in
    if d < date_1970_01_01 || d >= date_2038_01_01 then random_2038 ()
    else d

  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 Pervasives.compare t1.year t2.year with
    | 0 -> yday t1 - yday t2
    | 1 -> diff' t1 t2
    | -1 -> - (diff' t2 t1)
    | _ -> assert false

  let wday t = 
    (* 1970/01/01 is Thurdsday 
       Sunday : 0
       Mon : 1
       Tue : 2
       Wed : 3
       Thu : 4
       Fri : 5
       Sat : 6
    *)
    (diff t date_1970_01_01 + 4) mod 7
 
  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 Time = struct
  type t = Temporal_lexer.time = {
    hour : int; (* 00-24, 24 is only for 24:00:00 *)
    min  : int; (* 00-59 *)
    sec  : int; (* 00-60, 60 is for leap second *)
  }
    
  let to_string t = Printf.sprintf "%02d:%02d:%02d" t.hour t.min t.sec

  let is_valid t = 
    if t = { hour = 24; min = 0; sec = 0 } then true
    else 
      t.hour >= 0 && t.hour <= 23
      && t.min >= 0 && t.min <= 59
      && t.sec >= 0 && t.sec <= 60
  
  exception Parse_error
  
  let of_string_exn s = 
    try 
      let lexbuf = Lexing.from_string s in
      let res = Temporal_lexer.parse_time lexbuf in
      (* There may be some garbage in lexbuf *)
      if String.length s <> Lexing.lexeme_end lexbuf then raise Parse_error;
      if not & is_valid res then raise Parse_error;
      res
    with _ -> raise Parse_error
  
  let of_string s = Result.catch_exn & fun () -> of_string_exn s

  let random () = 
    if Random.int 30 = 0 then { hour = 24; min = 0; sec = 0 }
    else 
      { hour = Random.int 24;
        min = Random.int 60;
        sec = Random.int 61
      }

  let seconds_of_a_day = 86400. (* 24 * 60 * 60 *)

  let dsec t = 
    let open Overload.Float in
    float t.hour * 3600. + float t.min * 60. + float t.sec
end

module TZone = struct
  type t = [ `UTC | `Plus of int * int | `Minus of int * int ]

  let to_string = function
    | `UTC -> "Z"
    | `Plus (h, m) -> Printf.sprintf "+%02d:%02d" h m
    | `Minus (h, m) -> Printf.sprintf "-%02d:%02d" h m

  let is_valid = function
    | `UTC -> true
    | `Minus (0,0) -> false
    | `Plus (h, m) | `Minus (h, m) -> 0 <= h && h < 24 && 0 <= m && m < 60

  let in_secs = 
    let open Overload.Float in
    function
      | `UTC -> 0.0
      | `Plus (h, m) -> float h * 3600. + float m * 60.
      | `Minus (h, m) -> float h * (-3600.) + float m * (-60.)

  let rec random () = 
    let r = Random.int 25 in
    if r = 24 then `UTC
    else 
      let sign = Random.int 2 = 0 in
      let min = match Random.int 20 with
        | 0 -> 15
        | 1 -> 30
        | 2 -> 45
        | _ -> 0
      in
      if sign then `Plus (r, min)
      else if r = 0 && min = 0 then random ()  (* -00:00 is invalid *)
      else `Minus (r, min)
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 tm_of_date t = Option.catch_exn (fun () -> to_tm t) 

  let date_of_tm tm = 
    { year  = tm.tm_year + 1900;
      month = tm.tm_mon + 1;
      day   = tm.tm_mday }

  (* As UTC time *)
  let string_of_tm tm = 
    Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
      (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 & tm_of_date t in
    assert ((tm.tm_year, tm.tm_mon, tm.tm_mday, inv) = (2000 - 1900, 4 - 1, 1, `Ok))

end

module Datetime = struct
  type t = {
    date : Date.t;
    time : Time.t;
    zone : TZone.t
  }

  let to_string t = Printf.sprintf "%sT%s%s"
    (Date.to_string t.date)
    (Time.to_string t.time)
    (TZone.to_string t.zone)

  let is_valid t = 
    Date.is_valid t.date 
    && Time.is_valid t.time
    && TZone.is_valid t.zone

  let random () = { date = Date.random ();
                    time = Time.random ();
                    zone = TZone.random () }

  let random_2038 () = { date = Date.random_2038 ();
                         time = Time.random ();
                         zone = TZone.random () }

  exception Parse_error

  let of_string_exn s = 
    try 
      let lexbuf = Lexing.from_string s in
      let date = Temporal_lexer.parse_date lexbuf in
      let () = Temporal_lexer.parse_t lexbuf in
      let time = Temporal_lexer.parse_time lexbuf in
      let zone = Temporal_lexer.parse_tzone lexbuf in
      (* There may be some garbage in lexbuf *)
      if String.length s <> Lexing.lexeme_end lexbuf then raise Parse_error;
      let res = { date; time; zone } in
      if not & is_valid res then raise Parse_error;
      res
    with _ -> raise Parse_error
  
  let of_string s = Result.catch_exn & fun () -> of_string_exn s

  TEST_UNIT "parse" =
    for _i = 0 to 100000 do
      let t = random () in
      let s = to_string t in
      if of_string s <> `Ok t then begin
        prerr_endline s;
        assert false
      end
    done

  let epoch t =
    (* Seconds from 1970-01-01T00:00:00Z
       No leap second need to be counted.
    *)
    let open Overload.Float in
    let diff_days = float & Date.diff t.date Date.date_1970_01_01 in
    diff_days * Time.seconds_of_a_day
    + Time.dsec t.time
    + TZone.in_secs t.zone

  let of_utc_tm tm = 
    { date = Unix.date_of_tm tm;
      time = { Time.hour = tm.Unix0.tm_hour;
               min  = tm.Unix0.tm_min;
               sec  = tm.Unix0.tm_sec };
      zone = `UTC } 

  TEST_UNIT "epoch GMT" =
    for _i = 0 to 100000 do
      let dt = 
        let rec random () = 
          let dt = random_2038 () in
          (* Avoid EOD, since its is computed back to D+1:00:00:00 *)
          if dt.time = { Time.hour = 24; min = 0; sec = 0 } then random ()
          (* Avoid leap second, since its is computed back to +1min *)
          else if dt.time.Time.sec = 60 then random ()
          else dt
        in
        random ()
      in
      let dt = { dt with zone = `UTC } in
      let secs = epoch dt in
      let tm = Unix0.gmtime secs in
      let dt' = { date = Unix.date_of_tm tm;
                  time = { Time.hour = tm.Unix0.tm_hour;
                           min  = tm.Unix0.tm_min;
                           sec  = tm.Unix0.tm_sec };
                  zone = `UTC } 
      in
      if dt <> dt' then begin
        Format.eprintf "%s <> %s@." (to_string dt) (to_string dt');
        assert false
      end
    done
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;
             from_epoch : float;
             tm : Unix0.tm }

  let to_string t = 
    Printf.sprintf "{date = %s; from_epoch = %f; tm = %s}"
      (Date.to_string t.date)
      t.from_epoch
      (Unix.string_of_tm t.tm)

  let _create date = 
    match Unix.tm_of_date date with
    | None -> `Error (`Invalid_date date)
    | Some (from_epoch, tm, mal) ->
        match mal with
        | `Invalid -> `Error (`Invalid_date date)
        | `Ok -> `Ok { date; from_epoch; tm }

  let secs_of_day = 
    let open Xint64 in
    24L * 60L * 60L
    
  (* Use [Date.diff]. 

     This function is now purely testing purpose to check the correctness
     of [Date.diff].
     
     Pretty dirty rounding hack of local from_epochs which might be
     calculated from historical different local time settings.
     +-4hours are accepted.
  *)
  let diff t1 t2 = 
    let open Xint64 in
    let d = int64_of_float & t1.from_epoch -. t2.from_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.tm_of_date d with
    | Some (f, tm, `Ok) -> { date = d; from_epoch = f; tm }
    | Some (_, _, `Invalid) | 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

  TEST_UNIT "wday" =
    for _i = 0 to 1000 do    
      let t = random () in
      let wd = Date.wday t.date in
      if t.tm.Unix0.tm_wday <> wd then begin
        Format.eprintf "%s %d@."
          (to_string t) 
          wd;
        assert false
      end
    done

end