Source file core_time.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
(**
Outside of Core Time appears to be a single module with a number of submodules:
- Time
- Span
- Ofday
- Zone
The reality under the covers isn't as simple for a three reasons:
- We want as much Time functionality available to Core_kernel as possible, and
Core_kernel modules shouldn't rely on Unix functions. Some functions in Time
require Unix, which creates one split.
- We want some functionality to be functorized so that code can be shared
between Time and Time_ns.
- Time has internal circular dependencies. For instance, Ofday.now relies on
Time.now, but Time also wants to expose Time.to_date_ofday, which relies on Ofday.
We use a stack of modules to break the cycle.
This leads to the following modules within Core_kernel and Core:
Core_kernel.Span - the core type of span
Core_kernel.Ofday - the core type of ofday, which is really a constrained span
Core_kernel.Date - the core type of date
Core_kernel.Zone - the base functor for creating a Zone type
Core_kernel.Time_float0 - contains the base Time.t type and lays out the basic
relationship between Time, Span, Ofday, and Zone
Core_kernel.Time_float - ties Time, Span, Ofday, Zone, and Date together and provides
the higher level functions for them that don't rely on Unix
Core_kernel.Time - re-exposes Time_float
Core.Zone_cache - implements a caching layer between the Unix filesystem and Zones
Core.Core_date - adds the Unix dependent functions to Date
Core.Core_time - adds the Unix dependent functions to Time
Core - renames the Core_{base} modules to {base} for ease of access in
modules outside of Core
*)
open! Import
open! Int.Replace_polymorphic_compare
module Sys = Core_sys
include Core_time_intf
module Make
(Time0 : Time.S_kernel_without_zone)
(Time : Time.S_kernel with module Time := Time0)
= struct
module Span = struct
include Time.Span
let arg_type = Core_kernel.Command.Arg_type.create of_string
end
module Zone = struct
include Time.Zone
include (Timezone : Timezone.Extend_zone with type t := t)
let arg_type = Core_kernel.Command.Arg_type.create of_string
end
module Ofday = struct
include Time.Ofday
let arg_type = Core_kernel.Command.Arg_type.create of_string
let now ~zone = Time.to_ofday ~zone (Time.now ())
module Zoned = struct
type t =
{ ofday : Time.Ofday.t;
zone : Zone.t;
}
[@@deriving bin_io, fields, compare, equal, hash]
type sexp_repr = Time.Ofday.t * Zone.t
[@@deriving sexp]
let sexp_of_t t = [%sexp_of: sexp_repr] (t.ofday, t.zone)
let t_of_sexp sexp =
let (ofday, zone) = [%of_sexp: sexp_repr] sexp in
{ ofday; zone; }
;;
let to_time t date = Time.of_date_ofday ~zone:(zone t) date (ofday t)
let create ofday zone = { ofday; zone }
let create_local ofday = create ofday (Lazy.force Zone.local)
let of_string string : t =
match String.split string ~on:' ' with
| [ ofday; zone ] ->
{ ofday = Time.Ofday.of_string ofday;
zone = Zone.of_string zone;
}
| _ ->
failwithf "Ofday.Zoned.of_string %s" string ()
;;
let to_string (t : t) : string =
String.concat [
Time.Ofday.to_string t.ofday;
" ";
Zone.to_string t.zone ]
;;
let arg_type = Core_kernel.Command.Arg_type.create of_string
module With_nonchronological_compare = struct
type nonrec t = t
[@@deriving bin_io, compare, equal, sexp, hash]
end
include Pretty_printer.Register (struct
type nonrec t = t
let to_string = to_string
let module_name = "Core.Time.Ofday.Zoned"
end)
end
end
include (Time : module type of Time
with module Zone := Time.Zone
and module Ofday := Time.Ofday
and module Span := Time.Span)
let of_tm tm ~zone =
let
{ Core_unix.tm_year; tm_mon; tm_mday; tm_hour; tm_min; tm_sec
; tm_isdst = _; tm_wday = _; tm_yday = _ } = tm
in
let date =
Date.create_exn
~y:(tm_year + 1900)
~m:(Month.of_int_exn (tm_mon + 1))
~d:tm_mday
in
let ofday = Ofday.create ~hr:tm_hour ~min:tm_min ~sec:tm_sec () in
of_date_ofday ~zone date ofday
;;
let of_date_ofday_zoned date ofday_zoned =
Ofday.Zoned.to_time ofday_zoned date
let to_date_ofday_zoned t ~zone =
let (date,ofday) = to_date_ofday t ~zone in
(date, Ofday.Zoned.create ofday zone)
let to_ofday_zoned t ~zone =
let ofday = to_ofday t ~zone in
Ofday.Zoned.create ofday zone
let of_string_fix_proto utc str =
try
let expect_length = 21 in
let expect_dash = 8 in
if Char.(<>) str.[expect_dash] '-' then
failwithf "no dash in position %d" expect_dash ();
let zone =
match utc with
| `Utc -> Zone.utc
| `Local -> Lazy.force Zone.local
in
if Int.(>) (String.length str) expect_length then
failwithf "input too long" ();
of_date_ofday ~zone
(Date.of_string_iso8601_basic str ~pos:0)
(Ofday.of_string_iso8601_extended str ~pos:(expect_dash + 1))
with exn ->
invalid_argf "Time.of_string_fix_proto %s: %s" str (Exn.to_string exn) ()
;;
let to_string_fix_proto utc t =
let zone =
match utc with
| `Utc -> Zone.utc
| `Local -> Lazy.force Zone.local
in
let date, sec = to_date_ofday t ~zone in
(Date.to_string_iso8601_basic date) ^ "-" ^ (Ofday.to_millisecond_string sec)
;;
let format t s ~zone =
let epoch_time =
Zone.date_and_ofday_of_absolute_time zone t
|> Date_and_ofday.to_synthetic_span_since_epoch
|> Span.to_sec
in
Core_unix.strftime (Unix.gmtime epoch_time) s
;;
let parse s ~fmt ~zone =
Core_unix.strptime ~fmt s
|> of_tm ~zone
;;
let pause_for span =
let time_remaining =
let span = Span.min span (Span.scale Span.day 100.) in
Core_unix.nanosleep (Span.to_sec span)
in
if Float.(>) time_remaining 0.0
then `Remaining (Span.of_sec time_remaining)
else `Ok
;;
(** Pause and don't allow events to interrupt. *)
let rec pause span =
match pause_for span with
| `Remaining span -> pause span
| `Ok -> ()
;;
(** Pause but allow events to interrupt. *)
let interruptible_pause = pause_for
let rec pause_forever () =
pause (Span.of_day 1.0);
pause_forever ()
;;
let to_string t = to_string_abs t ~zone:(Lazy.force Zone.local)
let ensure_colon_in_offset offset =
if Char.(=) offset.[1] ':'
|| Char.(=) offset.[2] ':'
then offset
else begin
let offset_length = String.length offset in
if Int.(<) offset_length 3 || Int.(>) offset_length 4
then failwithf "invalid offset %s" offset ()
else String.concat
[ String.slice offset 0 (offset_length - 2)
; ":"
; String.slice offset (offset_length - 2) offset_length ]
end
;;
exception Time_string_not_absolute of string [@@deriving sexp]
let of_string_gen ~if_no_timezone s =
let default_zone () =
match if_no_timezone with
| `Fail -> raise (Time_string_not_absolute s);
| `Local -> Lazy.force Zone.local
| `Use_this_one zone -> zone
in
of_string_gen ~default_zone ~find_zone:Zone.find_exn s
;;
let of_string_abs s = of_string_gen ~if_no_timezone:`Fail s
let of_string s = of_string_gen ~if_no_timezone:`Local s
let arg_type = Core_kernel.Command.Arg_type.create of_string_abs
include Pretty_printer.Register (struct
type nonrec t = t
let to_string = to_string
let module_name = "Core.Time"
end)
let sexp_zone = ref Zone.local
let get_sexp_zone () = (Lazy.force !sexp_zone)
let set_sexp_zone zone = sexp_zone := lazy zone
let t_of_sexp_gen ~if_no_timezone sexp =
try
match sexp with
| Sexp.List [Sexp.Atom date; Sexp.Atom ofday; Sexp.Atom tz] ->
of_date_ofday ~zone:(Zone.find_exn tz)
(Date.of_string date) (Ofday.of_string ofday)
| Sexp.List [Sexp.Atom date; Sexp.Atom ofday_and_possibly_zone] ->
of_string_gen ~if_no_timezone (date ^ " " ^ ofday_and_possibly_zone)
| Sexp.Atom datetime ->
of_string_gen ~if_no_timezone datetime
| _ -> of_sexp_error "Time.t_of_sexp" sexp
with
| Of_sexp_error _ as e -> raise e
| e -> of_sexp_error (sprintf "Time.t_of_sexp: %s" (Exn.to_string e)) sexp
;;
let t_of_sexp sexp =
t_of_sexp_gen sexp ~if_no_timezone:(`Use_this_one (Lazy.force !sexp_zone))
let t_of_sexp_abs sexp =
t_of_sexp_gen sexp ~if_no_timezone:`Fail
let sexp_of_t_abs t ~zone =
Sexp.List (List.map (Time.to_string_abs_parts ~zone t) ~f:(fun s -> Sexp.Atom s))
;;
let sexp_of_t t = sexp_of_t_abs ~zone:(Lazy.force !sexp_zone) t
module type C = Comparable.Map_and_set_binable
with type t := t
and type comparator_witness := comparator_witness
let make_comparable ?(sexp_of_t = sexp_of_t) ?(t_of_sexp = t_of_sexp) ()
: (module C) =
(module struct
module C = struct
type nonrec t = t [@@deriving bin_io]
type nonrec comparator_witness = comparator_witness
let comparator = comparator
let sexp_of_t = sexp_of_t
let t_of_sexp = t_of_sexp
end
include C
module Map = Map.Make_binable_using_comparator (C)
module Set = Set.Make_binable_using_comparator (C)
end)
include (val make_comparable () ~t_of_sexp:(fun sexp ->
match Option.try_with (fun () ->
of_span_since_epoch (Span.of_sec (Float.t_of_sexp sexp))) with
| Some t -> t
| None -> t_of_sexp sexp
))
let%test _ =
Set.equal
(Set.of_list [epoch])
(Set.t_of_sexp
(Sexp.List [Float.sexp_of_t (Span.to_sec (to_span_since_epoch epoch))]))
;;
include Hashable.Make_binable (struct
type nonrec t = t [@@deriving bin_io, compare, hash, sexp]
end)
module Exposed_for_tests = struct
let ensure_colon_in_offset = ensure_colon_in_offset
end
end