Something went wrong. Try again.
My own corner of monopam
Something went wrong. Try again.
24 kB · 593 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594(*--------------------------------------------------------------------------- Copyright (c) 2025 Thomas Gazagnaire. All rights reserved. SPDX-License-Identifier: ISC ---------------------------------------------------------------------------*)
let ms_per_day = 86_400_000L
(* Unix epoch 1970-01-01 is Julian Day 2440587.5. *)let unix_epoch_ms = 210_866_760_000_000L
let text_of_value = function | Ast.Text s -> s | Blob s -> s | Int i -> Int64.to_string i | Float f -> Fmt.str "%g" f | Null -> ""
(* Broken-down calendar fields -> Julian Day in integer ms. Out-of-range day or month values are accepted and normalised by the arithmetic, so Feb 31 lands in March, as sqlite3 does for month arithmetic. *)let ijd_of_fields y mo d h mi s = let y, mo = if mo <= 2 then (y - 1, mo + 12) else (y, mo) in let a = y / 100 in let b = 2 - a + (a / 4) in let x1 = 36525 * (y + 4716) / 100 in let x2 = 306001 * (mo + 1) / 10000 in let days = float_of_int (x1 + x2 + d + b) -. 1524.5 in let day_ms = Int64.of_float (days *. 86_400_000.) in let time_ms = Int64.of_int ((h * 3_600_000) + (mi * 60_000)) in let sec_ms = Int64.of_float (Float.round (s *. 1000.)) in Int64.add (Int64.add day_ms time_ms) sec_ms
(* Julian Day in ms -> (year, month, day, hour, minute, seconds-with-fraction). The inverse of {!ijd_of_fields}, using the standard Gregorian conversion. *)let fields_of_ijd ijd = let z = Int64.to_int (Int64.div (Int64.add ijd 43_200_000L) ms_per_day) in let a = int_of_float ((float_of_int z -. 1_867_216.25) /. 36524.25) in let a = z + 1 + a - (a / 4) in let b = a + 1524 in let c = int_of_float ((float_of_int b -. 122.1) /. 365.25) in let d = int_of_float (365.25 *. float_of_int c) in let e = int_of_float (float_of_int (b - d) /. 30.6001) in let x1 = int_of_float (30.6001 *. float_of_int e) in let day = b - d - x1 in let month = if e < 14 then e - 1 else e - 13 in let year = if month > 2 then c - 4716 else c - 4715 in let into = Int64.to_int (Int64.rem (Int64.add ijd 43_200_000L) ms_per_day) in let into = if into < 0 then into + 86_400_000 else into in let h = into / 3_600_000 in let mi = into mod 3_600_000 / 60_000 in let sec = float_of_int (into mod 60_000) /. 1000. in (year, month, day, h, mi, sec)
let day_of_week ijd = (* 0 = Sunday. JD+0.5 floored is the civil day; +1 mod 7 puts Sunday at 0. *) let z = Int64.to_int (Int64.div (Int64.add ijd 43_200_000L) ms_per_day) in ((z mod 7) + 7 + 1) mod 7
(* ── Parsing a time value ────────────────────────────────────── *)
let sub_int s a b = int_of_string (String.sub s a (b - a))
(* Parse the [HH:MM[:SS[.fff]]] tail of a time string into (h, mi, seconds). *)let parse_hms t = match String.split_on_char ':' t with | [ h; m ] -> (int_of_string h, int_of_string m, 0.) | [ h; m; s ] -> (int_of_string h, int_of_string m, float_of_string s) | _ -> failwith "bad time"
(* Reject calendar fields outside sqlite3's accepted ranges; an out-of-range literal date/time yields NULL rather than a value. *)let validate y mo d h mi s = if mo < 1 || mo > 12 || d < 1 || d > 31 || h > 24 || mi > 59 || s >= 60. || y < 0 then failwith "date/time field out of range"
(* Strip a trailing 'Z' or +/-HH:MM timezone, returning the offset in minutes, the remaining time text, and whether a timezone was present (so a later 'utc' modifier knows the value is already UTC and is a no-op). *)let split_tz t = let n = String.length t in if n > 0 && (t.[n - 1] = 'Z' || t.[n - 1] = 'z') then (0, String.sub t 0 (n - 1), true) else if n >= 6 && (t.[n - 6] = '+' || t.[n - 6] = '-') && t.[n - 3] = ':' then let sign = if t.[n - 6] = '+' then 1 else -1 in let hh = int_of_string (String.sub t (n - 5) 2) in let mm = int_of_string (String.sub t (n - 2) 2) in (sign * ((hh * 60) + mm), String.sub t 0 (n - 6), true) else (0, t, false)
let parse_string str = let str = String.trim str in if String.length str >= 6 && String.contains str '-' then begin (* date, optionally followed by ' ' or 'T' and a time *) let date_part, time_part = match String.index_opt str ' ' with | Some i -> ( String.sub str 0 i, Some (String.sub str (i + 1) (String.length str - i - 1)) ) | None -> ( match String.index_opt str 'T' with | Some i -> ( String.sub str 0 i, Some (String.sub str (i + 1) (String.length str - i - 1)) ) | None -> (str, None)) in let y = sub_int date_part 0 4 in let mo = sub_int date_part 5 7 in let d = sub_int date_part 8 10 in let offset, h, mi, s, had_tz = match time_part with | None -> (0, 0, 0, 0., false) | Some t -> let offset, t, had_tz = split_tz t in let h, mi, s = parse_hms (String.trim t) in (offset, h, mi, s, had_tz) in validate y mo d h mi s; (* Shift an offset-bearing local time back to UTC (SQLite stores UTC); the Julian Day is in integer milliseconds. *) ( Int64.sub (ijd_of_fields y mo d h mi s) (Int64.of_int (offset * 60_000)), had_tz ) end else if String.contains str ':' then begin let offset, t, had_tz = split_tz (String.trim str) in let h, mi, s = parse_hms (String.trim t) in validate 2000 1 1 h mi s; ( Int64.sub (ijd_of_fields 2000 1 1 h mi s) (Int64.of_int (offset * 60_000)), had_tz ) end else failwith "unrecognized date/time string"
(* How a bare number in the value position is read. A leading modifier can say ('unixepoch', 'auto'); with none it is a Julian Day. *)type number = Julian_day | Unix_epoch | Auto
(* The first Julian Day that no longer renders as a date sqlite3 will print. setRawDateNumber computes a day count from a number below it and from no other, so a number at or above it -- or below zero -- is no day until 'auto' or 'unixepoch' says what it is. *)let auto_julian_limit = 5_373_484.5
(* The span 'unixepoch' converts within, in milliseconds since the Julian epoch, which is the Julian span measured where sqlite3 measures it (date.c parseModifier: "r>=0.0 && r<464269060800000.0"). *)let unixepoch_limit_ms = 464_269_060_800_000.
(* The span 'auto' reads unix seconds within. sqlite3 states this one in whole seconds instead -- -4713-11-24 12:00:00 to 9999-12-31 23:59:59, written "-21086676*10000" and "25340230*10000+799" -- so it ends half a second before the millisecond span does. *)let auto_unix_first = -210_866_760_000.let auto_unix_last = 253_402_300_799.
(* The Julian Day, in integer milliseconds, of the raw date number [n] read as [number]. sqlite3 rounds each conversion rather than truncating it (setRawDateNumber and parseModifier both add 0.5 before the cast). A number no reading places fails, which the call surfaces as NULL: there the value is still raw when the calendar is computed, and computeJD refuses it. *)let ijd_of_raw ~number n = let of_julian_day () = Int64.of_float ((n *. 86_400_000.) +. 0.5) in let of_unix_seconds () = let ms = (n *. 1000.) +. Int64.to_float unix_epoch_ms in if ms >= 0. && ms < unixepoch_limit_ms then Int64.of_float (ms +. 0.5) else failwith "date/time: unix seconds out of range" in let is_julian_day = n >= 0. && n < auto_julian_limit in match number with | Julian_day -> if is_julian_day then of_julian_day () else failwith "date/time: number is no Julian day" | Unix_epoch -> of_unix_seconds () | Auto -> if is_julian_day then of_julian_day () else if n >= auto_unix_first && n <= auto_unix_last then of_unix_seconds () else failwith "date/time: number is no date"
(* The bytes sqlite3Isspace answers for, which is what both AtoF and the modifier parse skip. *)let is_space = function | ' ' | '\t' | '\n' | '\011' | '\012' | '\r' -> true | _ -> false
(* [skip p s i] is the first index at or after [i] where [s] stops satisfying [p], and the length of [s] where it never does. *)let skip p s i = let n = String.length s in let j = ref i in while !j < n && p s.[!j] do incr j done; !j
let at s i c = i < String.length s && s.[i] = c
(* Just past an optional sign at [i]; [i] itself where none is written. *)let after_sign s i = if at s i '+' || at s i '-' then i + 1 else i
(* Just past the run of digits at [i], and [None] where there is none. *)let after_digits s i = let j = skip (fun c -> c >= '0' && c <= '9') s i in if j = i then None else Some j
(* Just past a signed mantissa at [i] -- digits, then optionally a point and more, or a point and digits alone -- and [None] without a digit in it. *)let after_mantissa s i = let i = after_sign s i in match after_digits s i with | Some j when at s j '.' -> Some (Option.value (after_digits s (j + 1)) ~default:(j + 1)) | Some _ as whole -> whole | None -> if at s i '.' then after_digits s (i + 1) else None
(* Just past an exponent at [i]; [i] where none is written, and [None] where one is and carries no digit. *)let after_exponent s i = if at s i 'e' || at s i 'E' then after_digits s (after_sign s (i + 1)) else Some i
let decimal_of_string s = let from = skip is_space s 0 in match Option.bind (after_mantissa s from) (after_exponent s) with | Some upto when skip is_space s upto = String.length s -> float_of_string_opt (String.sub s from (upto - from)) | Some _ | None -> None
(* Parse the leading time value under [number], and 'now' from the injected [now] (milliseconds since the unix epoch). Returns the Julian Day in integer milliseconds and whether the value is already in UTC (a number, or a tz-bearing string), so a 'utc' modifier is a no-op. *)let parse_value ~now ~number v = match v with | Ast.Int _ | Float _ -> let n = match v with Int i -> Int64.to_float i | Float f -> f | _ -> 0. in (ijd_of_raw ~number n, true) | _ -> ( (* 'now' is compared on the value as written, case-folded, so a padded one is not it -- the same rule {!reads_the_clock} applies. *) let raw = text_of_value v in match (String.lowercase_ascii raw, now) with | "now", Some ms -> (Int64.add unix_epoch_ms ms, true) | "now", None -> failwith "date/time: 'now' needs an injected instant" | _ -> ( let spelled = match number with | Unix_epoch -> None | Julian_day | Auto -> ( try Some (parse_string raw) with Failure _ | Invalid_argument _ -> None) in match spelled with | Some parsed -> parsed | None -> ( match decimal_of_string raw with | Some n -> (ijd_of_raw ~number n, true) | None -> failwith "unrecognized date/time string")))
(* ── Modifiers ───────────────────────────────────────────────── *)
let split_amount s = let n = String.length s in let upto = skip (fun c -> not (is_space c)) s 0 in let from = skip is_space s upto in match decimal_of_string (String.sub s 0 upto) with | Some amount -> Some (amount, String.sub s from (n - from)) | None -> None
let is_digit c = c >= '0' && c <= '9'
(* The number written in the two digits at [i] of [s], and [None] unless both are digits and it is at most [max] (date.c, getDigits). *)let two_digits s i ~max = if i + 1 < String.length s && is_digit s.[i] && is_digit s.[i + 1] then let v = ((Char.code s.[i] - 48) * 10) + (Char.code s.[i + 1] - 48) in if v <= max then Some v else None else None
(* The zone written from [i] to the end of [s], in minutes east of UTC: none, [Z], or [(+|-)HH:MM], with blanks around it (date.c, parseTimezone). *)let trailing_zone s i = let n = String.length s in let ends j = skip is_space s j = n in let i = skip is_space s i in if i = n then Some 0 else match s.[i] with | 'z' | 'Z' -> if ends (i + 1) then Some 0 else None | ('+' | '-') as c -> ( let sign = if c = '+' then 1 else -1 in match (two_digits s (i + 1) ~max:14, two_digits s (i + 4) ~max:59) with | Some h, Some mi when at s (i + 3) ':' && ends (i + 6) -> Some (sign * ((h * 60) + mi)) | _ -> None) | _ -> None
(* The milliseconds a modifier spelled as a clock reading, [(+|-)HH:MM[:SS[.FFF]]] and an optional zone, shifts the time by, and [None] for any other modifier. The reading is taken modulo a day, as date.c's parseModifier takes the time of day of the instant parseHhMmSs computes. *)let clock_shift m = let sign, i = if at m 0 '+' then (1L, 1) else if at m 0 '-' then (-1L, 1) else (1L, 0) in let seconds j = if not (at m j ':') then Some (0, 0., j) else match two_digits m (j + 1) ~max:59 with | None -> None | Some sec -> let j = j + 3 in if at m j '.' && j + 1 < String.length m && is_digit m.[j + 1] then let k = skip is_digit m (j + 1) in let frac = float_of_string ("0." ^ String.sub m (j + 1) (k - j - 1)) in Some (sec, Float.min frac 0.999, k) else Some (sec, 0., j) in match (two_digits m i ~max:24, two_digits m (i + 3) ~max:59) with | Some h, Some mi when at m (i + 2) ':' -> ( match seconds (i + 5) with | None -> None | Some (sec, frac, j) -> ( match trailing_zone m j with | None -> None | Some tz -> let ms = Int64.of_int ((h * 3_600_000) + (mi * 60_000) - (tz * 60_000)) in let ms = Int64.add ms (Int64.of_float (((float_of_int sec +. frac) *. 1000.) +. 0.5)) in let ms = Int64.rem ms ms_per_day in let ms = if ms < 0L then Int64.add ms ms_per_day else ms in Some (Int64.mul sign ms))) | _ -> None
let normalize_month y mo = let total = (y * 12) + (mo - 1) in (total / 12, (total mod 12) + 1)
let weekday_of_modifier m = let prefix = "weekday " in let n = String.length prefix in if String.length m <= n || String.sub m 0 n <> prefix then None else match decimal_of_string (String.sub m n (String.length m - n)) with | Some r when r >= 0. && r < 7. && Float.is_integer r -> Some (int_of_float r) | Some _ | None -> None
(* The injected offset as the milliseconds to add to a UTC instant to reach local time. [zone] is asked in the units its caller thinks in: seconds east of UTC, at an instant in milliseconds since the unix epoch. *)let zone_ms zone ijd = Int64.of_int (zone (Int64.sub ijd unix_epoch_ms) * 1000)
let apply_modifier ~had_tz ~zone ijd m = let m = String.lowercase_ascii m in if m = "start of day" then let y, mo, d, _, _, _ = fields_of_ijd ijd in ijd_of_fields y mo d 0 0 0. else if m = "start of month" then let y, mo, _, _, _, _ = fields_of_ijd ijd in ijd_of_fields y mo 1 0 0 0. else if m = "start of year" then let y, _, _, _, _, _ = fields_of_ijd ijd in ijd_of_fields y 1 1 0 0 0. else if m = "utc" then (* The value is stored in UTC. 'utc' is a no-op when it already carries a timezone (so [datetime('..Z','utc')] keeps the time); otherwise the value is a local time and comes back by the injected offset. *) if had_tz then ijd else Int64.sub ijd (zone_ms zone ijd) else if m = "localtime" then (* The mirror, and unconditional: sqlite3 reads tzSet in 'utc' and not here, so a tz-bearing value shifts too. *) Int64.add ijd (zone_ms zone ijd) else match weekday_of_modifier m with | Some n -> (* Forward to the next day of the week [n], keeping the time of day: the shift is whole days, and none at all when it is already there. *) let z = day_of_week ijd in let z = if z > n then z - 7 else z in Int64.add ijd (Int64.mul (Int64.of_int (n - z)) ms_per_day) | None -> ( match clock_shift m with | Some ms -> Int64.add ijd ms | None -> ( let amount, unit = match split_amount m with | Some parts -> parts | None -> Fmt.failwith "date/time: unknown modifier %S" m in match unit with | "day" | "days" -> Int64.add ijd (Int64.of_float (amount *. 86_400_000.)) | "hour" | "hours" -> Int64.add ijd (Int64.of_float (amount *. 3_600_000.)) | "minute" | "minutes" -> Int64.add ijd (Int64.of_float (amount *. 60_000.)) | "second" | "seconds" -> Int64.add ijd (Int64.of_float (amount *. 1000.)) | "month" | "months" -> let y, mo, d, h, mi, s = fields_of_ijd ijd in let y, mo = normalize_month y (mo + int_of_float amount) in ijd_of_fields y mo d h mi s | "year" | "years" -> let y, mo, d, h, mi, s = fields_of_ijd ijd in ijd_of_fields (y + int_of_float amount) mo d h mi s | _ -> Fmt.failwith "date/time: unknown modifier %S" m))
(* An evaluated call: the instant, and whether a 'subsec' modifier asked for the millisecond wherever the rendering prints seconds. sqlite3 keeps the second on the DateTime rather than folding it into the instant (useSubsec). *)type instant = { ijd : int64; subsec : bool }
(* A modifier that is a flag rather than arithmetic is compared on the text as written, case-folded, exactly as sqlite3's parseModifier switches on its first byte -- so a padded one is no flag. *)let named w m = String.lowercase_ascii m = w
(* The full evaluation: read the flags, parse the time value, then fold the remaining modifiers. Any unparseable value, out-of-range field, or unknown modifier yields None, which the SQL functions surface as NULL -- sqlite3 never errors on a bad date. *)let evaluate ?now ?(zone : int64 -> int = fun _ -> 0) args = match args with | [] -> None | Ast.Null :: _ -> None | v :: mods -> ( try let mods = List.map text_of_value mods in (* 'unixepoch' and 'auto' say how the value itself is read, so sqlite3 honours either only in first position ("if( idx>1 ) return 1"); one written later is left to fail as an unknown modifier. *) let number, mods = match mods with | m :: rest when named "unixepoch" m -> (Unix_epoch, rest) | m :: rest when named "auto" m -> (Auto, rest) | _ -> (Julian_day, mods) in (* 'subsec' says how the answer is rendered, so it may sit anywhere. *) let is_subsec m = named "subsec" m || named "subsecond" m in let subsec = List.exists is_subsec mods in let mods = List.filter (fun m -> not (is_subsec m)) mods in let ijd, had_tz = parse_value ~now ~number v in Some { ijd = List.fold_left (apply_modifier ~had_tz ~zone) ijd mods; subsec; } with Failure _ | Invalid_argument _ -> None)
(* ── Formatting ──────────────────────────────────────────────── *)
let day_of_year y mo d = let jan1 = ijd_of_fields y 1 1 0 0 0. in let this = ijd_of_fields y mo d 0 0 0. in 1 + Int64.to_int (Int64.div (Int64.sub this jan1) ms_per_day)
let fmt_date ijd = let y, mo, d, _, _, _ = fields_of_ijd ijd in Fmt.str "%04d-%02d-%02d" y mo d
(* Under 'subsec' the seconds carry their millisecond, which is the only thing the flag changes about a rendering. *)let fmt_time ~subsec ijd = let _, _, _, h, mi, s = fields_of_ijd ijd in if subsec then Fmt.str "%02d:%02d:%06.3f" h mi s else Fmt.str "%02d:%02d:%02d" h mi (int_of_float s)
let fmt_datetime ~subsec ijd = fmt_date ijd ^ " " ^ fmt_time ~subsec ijdlet julianday ijd = Int64.to_float ijd /. 86_400_000.let unixepoch_of ijd = Int64.div (Int64.sub ijd unix_epoch_ms) 1000L
(* The same instant as a real, so 'subsec' keeps the millisecond that the integer second drops. *)let unixepoch_subsec ijd = Int64.to_float (Int64.sub ijd unix_epoch_ms) /. 1000.
(* Left-pad an integer with zeros to [width] digits. *)let zpad width n = let s = string_of_int n in let p = width - String.length s in if p <= 0 then s else String.make p '0' ^ s
(* strftime substitutions. The field strings are computed once, so the loop over the format only selects among them. *)let strftime ~subsec fmt ijd = let y, mo, d, h, mi, s = fields_of_ijd ijd in let doy = day_of_year y mo d in let dow = day_of_week ijd in let sec_frac = let whole = int_of_float s in let frac = int_of_float (Float.round ((s -. float_of_int whole) *. 1000.)) in zpad 2 whole ^ "." ^ zpad 3 frac in (* Monday-based week number, as sqlite3's %W computes it. *) let week = zpad 2 ((doy + 6 - ((dow + 6) mod 7)) / 7) in let subst = function | 'Y' -> zpad 4 y | 'm' -> zpad 2 mo | 'd' -> zpad 2 d | 'H' -> zpad 2 h | 'M' -> zpad 2 mi | 'S' -> zpad 2 (int_of_float s) | 'j' -> zpad 3 doy | 'w' -> string_of_int dow | 'W' -> week | 'f' -> sec_frac | 's' -> if subsec then Fmt.str "%.3f" (unixepoch_subsec ijd) else Int64.to_string (unixepoch_of ijd) (* the Julian day as sqlite3 prints it: "%.16g" of the instant in days (date.c, strftimeFunc case 'J'), so a whole day carries no fraction and no trailing point, and a fractional one sixteen significant digits *) | 'J' -> Fmt.str "%.16g" (julianday ijd) | '%' -> "%" | c -> "%" ^ String.make 1 c in let buf = Buffer.create (String.length fmt) in let n = String.length fmt in let i = ref 0 in while !i < n do if fmt.[!i] = '%' && !i + 1 < n then begin Buffer.add_string buf (subst fmt.[!i + 1]); i := !i + 2 end else begin Buffer.add_char buf fmt.[!i]; incr i end done; Buffer.contents buf
(* ── Public entry: the SQL date/time functions ───────────────── *)
(* The time value and modifiers of a call, which for strftime are what follows the format string. *)let time_args name args = match (name, args) with "strftime", _ :: rest -> rest | _ -> args
let reads_the_clock name args = let is w v = match (v : Ast.value) with | Text s -> List.mem (String.lowercase_ascii s) w | _ -> false in match time_args name args with | [] -> true | v :: mods -> is [ "now"; "subsec"; "subsecond" ] v || List.exists (is [ "localtime"; "utc" ]) mods
let call ?now ?zone name args = let eval args = evaluate ?now ?zone args in match name with | "date" -> ( match eval args with Some t -> Ast.Text (fmt_date t.ijd) | None -> Null) | "time" -> ( match eval args with | Some t -> Ast.Text (fmt_time ~subsec:t.subsec t.ijd) | None -> Null) | "datetime" -> ( match eval args with | Some t -> Ast.Text (fmt_datetime ~subsec:t.subsec t.ijd) | None -> Null) | "julianday" -> ( match eval args with | Some t -> Ast.Float (julianday t.ijd) | None -> Null) | "unixepoch" -> ( match eval args with | Some t when t.subsec -> Ast.Float (unixepoch_subsec t.ijd) | Some t -> Ast.Int (unixepoch_of t.ijd) | None -> Null) | "strftime" -> ( match args with | fmt :: rest -> ( match eval rest with | Some t -> Ast.Text (strftime ~subsec:t.subsec (text_of_value fmt) t.ijd) | None -> Null) | [] -> Null) | _ -> invalid_arg ("Datetime.call: not a date/time function: " ^ name)