Source file ofday_helpers.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
open! Import
open Std_internal
open Digit_string_helpers
let suffixes char =
let sprintf = Printf.sprintf in
[ sprintf "%c" char; sprintf "%cM" char; sprintf "%c.M" char; sprintf "%c.M." char ]
|> List.concat_map ~f:(fun suffix ->
[ String.lowercase suffix; String.uppercase suffix ])
;;
let am_suffixes = lazy (suffixes 'A')
let pm_suffixes = lazy (suffixes 'P')
let rec find_suffix string suffixes =
match suffixes with
| suffix :: suffixes ->
if String.is_suffix string ~suffix then suffix else find_suffix string suffixes
| [] -> ""
;;
let has_colon string pos ~until = pos < until && Char.equal ':' string.[pos]
let char_is_decimal_point string pos = Char.equal '.' string.[pos]
let decrement_length_if_ends_in_space string len =
if len > 0 && Char.equal ' ' string.[len - 1] then len - 1 else len
;;
let[@cold] invalid_string string ~reason =
raise_s [%message "Time.Ofday: invalid string" string reason]
;;
let check_digits_with_underscore_and_return_if_nonzero string pos ~until =
let nonzero = ref false in
for pos = pos to until - 1 do
match string.[pos] with
| '0' | '_' -> ()
| '1' .. '9' -> nonzero := true
| _ ->
invalid_string
string
~reason:"expected digits and/or underscores after decimal point"
done;
!nonzero
;;
let check_digits_without_underscore_and_return_if_nonzero string pos ~until =
let nonzero = ref false in
for pos = pos to until - 1 do
match string.[pos] with
| '0' -> ()
| '1' .. '9' -> nonzero := true
| _ -> invalid_string string ~reason:"expected digits after decimal point"
done;
!nonzero
;;
let parse string ~f =
let len = String.length string in
let am_or_pm, until =
match
( find_suffix string (Lazy.force am_suffixes)
, find_suffix string (Lazy.force pm_suffixes) )
with
| "", "" -> `hr_24, len
| am, "" -> `hr_AM, decrement_length_if_ends_in_space string (len - String.length am)
| "", pm -> `hr_PM, decrement_length_if_ends_in_space string (len - String.length pm)
| _, _ -> `hr_24, assert false
in
let pos = 0 in
let pos, hr, expect_minutes_and_seconds =
if has_colon string (pos + 1) ~until
then
pos + 2, read_1_digit_int string ~pos, `Minutes_and_maybe_seconds
else if has_colon string (pos + 2) ~until
then
pos + 3, read_2_digit_int string ~pos, `Minutes_and_maybe_seconds
else if pos + 1 = until
then
pos + 1, read_1_digit_int string ~pos, `Neither_minutes_nor_seconds
else if pos + 2 = until
then
pos + 2, read_2_digit_int string ~pos, `Neither_minutes_nor_seconds
else pos + 2, read_2_digit_int string ~pos, `Minutes_but_not_seconds
in
let pos, min, expect_seconds =
match expect_minutes_and_seconds with
| `Neither_minutes_nor_seconds ->
pos, 0, false
| (`Minutes_and_maybe_seconds | `Minutes_but_not_seconds) as maybe_seconds ->
if has_colon string (pos + 2) ~until
then
( pos + 3
, read_2_digit_int string ~pos
, match maybe_seconds with
| `Minutes_and_maybe_seconds -> true
| `Minutes_but_not_seconds ->
invalid_string string ~reason:"expected end of string after minutes" )
else if pos + 2 = until
then pos + 2, read_2_digit_int string ~pos, false
else
invalid_string
string
~reason:"expected colon or am/pm suffix with optional space after minutes"
in
let sec, subsec_pos, subsec_len, subsec_nonzero =
match expect_seconds with
| false ->
if pos = until
then 0, pos, 0, false
else
invalid_string string ~reason:"BUG: did not expect seconds, but found them"
| true ->
if pos + 2 > until
then
invalid_string string ~reason:"expected two digits of seconds"
else (
let sec = read_2_digit_int string ~pos in
let pos = pos + 2 in
if pos = until
then sec, pos, 0, false
else if pos < until && char_is_decimal_point string pos
then
( sec
, pos
, until - pos
, check_digits_with_underscore_and_return_if_nonzero string (pos + 1) ~until )
else
invalid_string
string
~reason:"expected decimal point or am/pm suffix after seconds")
in
let hr =
match am_or_pm with
| `hr_AM ->
if hr < 1 || hr > 12
then invalid_string string ~reason:"hours out of bounds"
else if hr = 12
then 0
else hr
| `hr_PM ->
if hr < 1 || hr > 12
then invalid_string string ~reason:"hours out of bounds"
else if hr = 12
then 12
else hr + 12
| `hr_24 ->
(match expect_minutes_and_seconds with
| `Neither_minutes_nor_seconds ->
invalid_string string ~reason:"hours without minutes or AM/PM"
| `Minutes_but_not_seconds | `Minutes_and_maybe_seconds ->
if hr > 24
then invalid_string string ~reason:"hours out of bounds"
else if hr = 24 && (min > 0 || sec > 0 || subsec_nonzero)
then invalid_string string ~reason:"time is past 24:00:00"
else hr)
in
let min =
if min > 59 then invalid_string string ~reason:"minutes out of bounds" else min
in
let sec =
if sec > 60 then invalid_string string ~reason:"seconds out of bounds" else sec
in
let subsec_len = if sec = 60 || not subsec_nonzero then 0 else subsec_len in
f string ~hr ~min ~sec ~subsec_pos ~subsec_len
;;
let parse_iso8601_extended ?pos ?len str ~f =
let pos, len =
match
Ordered_collection_common.get_pos_len () ?pos ?len ~total_length:(String.length str)
with
| Result.Ok z -> z
| Result.Error s ->
failwithf "Ofday.of_string_iso8601_extended: %s" (Error.to_string_mach s) ()
in
if len < 2
then failwith "len < 2"
else (
let hr = read_2_digit_int str ~pos in
if hr > 24 then failwith "hour > 24";
if len = 2
then f str ~hr ~min:0 ~sec:0 ~subsec_pos:(pos + len) ~subsec_len:0
else if len < 5
then failwith "2 < len < 5"
else if not (Char.equal str.[pos + 2] ':')
then failwith "first colon missing"
else (
let min = read_2_digit_int str ~pos:(pos + 3) in
if min >= 60 then failwith "minute > 60";
if hr = 24 && min <> 0 then failwith "24 hours and non-zero minute";
if len = 5
then f str ~hr ~min ~sec:0 ~subsec_pos:(pos + len) ~subsec_len:0
else if len < 8
then failwith "5 < len < 8"
else if not (Char.equal str.[pos + 5] ':')
then failwith "second colon missing"
else (
let sec = read_2_digit_int str ~pos:(pos + 6) in
if sec > 60 then failwithf "invalid second: %i" sec ();
if hr = 24 && sec <> 0 then failwith "24 hours and non-zero seconds";
if len = 8
then f str ~hr ~min ~sec ~subsec_pos:(pos + len) ~subsec_len:0
else if len = 9
then failwith "length = 9"
else (
match str.[pos + 8] with
| '.' | ',' ->
let subsec_pos = pos + 8 in
let subsec_len =
match
check_digits_without_underscore_and_return_if_nonzero
str
(subsec_pos + 1)
~until:(pos + len)
with
| true when sec = 60 -> 0
| true when hr = 24 -> failwith "24 hours and non-zero subseconds"
| _ -> len - 8
in
f str ~hr ~min ~sec ~subsec_pos ~subsec_len
| _ -> failwith "missing subsecond separator"))))
;;