diff options
Diffstat (limited to 'stdlib/source/lux/time/instant.lux')
| -rw-r--r-- | stdlib/source/lux/time/instant.lux | 304 |
1 files changed, 304 insertions, 0 deletions
diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux new file mode 100644 index 000000000..0e9fc22f6 --- /dev/null +++ b/stdlib/source/lux/time/instant.lux @@ -0,0 +1,304 @@ +(;module: + lux + (lux [io #- run] + (control eq + order + codec + [monad #+ do Monad] + ["p" parser]) + (data [text "text/" Monoid<Text>] + (text ["l" lexer] + format) + [number] + ["R" result] + (coll [list "L/" Fold<List> Functor<List>] + ["v" vector "v/" Functor<Vector> Fold<Vector>])) + (type model)) + (.. ["../d" duration "../d/" ;Order<Duration>])) + +(model: #export Instant + {#;doc "Instant is defined as milliseconds since the epoch."} + Int + + (def: #export from-millis + (-> Int Instant) + (|>. @model)) + + (def: #export to-millis + (-> Instant Int) + (|>. @repr)) + + (def: #export (span param subject) + (-> Instant Instant ../d;Duration) + (../d;from-millis (i.- (@repr param) (@repr subject)))) + + (struct: #export _ (Eq Instant) + (def: (= param subject) + (i.= (@repr param) (@repr subject)))) + + (struct: #export _ (Order Instant) + (def: eq Eq<Instant>) + (do-template [<name> <op>] + [(def: (<name> param subject) + (<op> (@repr param) (@repr subject)))] + + [< i.<] + [<= i.<=] + [> i.>] + [>= i.>=] + )) + + (def: #export (shift duration instant) + (-> ../d;Duration Instant Instant) + (@model (i.+ (../d;to-millis duration) (@repr instant)))) + + (def: #export (relative instant) + (-> Instant ../d;Duration) + (|> instant @repr ../d;from-millis)) + + (def: #export (absolute offset) + (-> ../d;Duration Instant) + (|> offset ../d;to-millis @model)) + ) + +(def: #export epoch + {#;doc "The instant corresponding to 1970-01-01T00:00:00Z"} + Instant + (from-millis 0)) + +## Codec::encode +(def: (divisible? factor input) + (-> Int Int Bool) + (|> input (i.% factor) (i.= 0))) + +(def: (leap-year? year) + (-> Int Bool) + (and (divisible? 4 year) + (or (not (divisible? 100 year)) + (divisible? 400 year)))) + +(def: epoch-year Int 1970) + +(def: (find-year now) + (-> Instant [Int ../d;Duration]) + (loop [reference epoch-year + time-left (relative now)] + (let [year (if (leap-year? reference) + ../d;leap-year + ../d;normal-year)] + (if (i.= 0 (../d;query year time-left)) + [reference time-left] + (if (../d/>= ../d;empty time-left) + (recur (i.inc reference) (../d;merge (../d;scale -1 year) time-left)) + (recur (i.dec reference) (../d;merge year time-left))) + )))) + +(def: normal-months + (v;Vector Nat) + (v;vector +31 +28 +31 + +30 +31 +30 + +31 +31 +30 + +31 +30 +31)) + +(def: leap-year-months + (v;Vector Nat) + (v;update [+1] n.inc normal-months)) + +(def: (find-month months time) + (-> (v;Vector Nat) ../d;Duration [Nat ../d;Duration]) + (if (../d/>= ../d;empty time) + (v/fold (function [month-days [current-month time-left]] + (let [month-duration (../d;scale (nat-to-int month-days) ../d;day)] + (if (i.= 0 (../d;query month-duration time-left)) + [current-month time-left] + [(n.inc current-month) (../d;merge (../d;scale -1 month-duration) time-left)]))) + [+0 time] + months) + (v/fold (function [month-days [current-month time-left]] + (let [month-duration (../d;scale (nat-to-int month-days) ../d;day)] + (if (i.= 0 (../d;query month-duration time-left)) + [current-month time-left] + [(n.dec current-month) (../d;merge month-duration time-left)]))) + [+11 time] + (v;reverse months)))) + +(def: (pad value) + (-> Int Text) + (if (i.< 10 value) + (text/append "0" (%i value)) + (%i value))) + +(def: (adjust-negative space duration) + (-> ../d;Duration ../d;Duration ../d;Duration) + (if (../d;negative? duration) + (../d;merge space duration) + duration)) + +(def: (encode-millis millis) + (-> Int Text) + (cond (i.= 0 millis) "" + (i.< 10 millis) (format ".00" (%i millis)) + (i.< 100 millis) (format ".0" (%i millis)) + ## (i.< 1_000 millis) + (format "." (%i millis)))) + +(def: seconds-per-day Int (../d;query ../d;second ../d;day)) +(def: days-up-to-epoch Int 719468) + +(def: (extract-date instant) + (-> Instant [[Int Int Int] ../d;Duration]) + (let [offset (relative instant) + seconds (../d;query ../d;second offset) + z (|> seconds (i./ seconds-per-day) (i.+ days-up-to-epoch)) + era (i./ 146097 + (if (i.>= 0 z) + z + (i.- 146096 z))) + days-of-era (|> z (i.- (i.* 146097 era))) + years-of-era (|> days-of-era + (i.- (i./ 1460 days-of-era)) + (i.+ (i./ 36524 days-of-era)) + (i.- (i./ 146096 days-of-era)) + (i./ 365)) + year (|> years-of-era (i.+ (i.* 400 era))) + days-of-year (|> days-of-era + (i.- (|> (i.* 365 years-of-era) + (i.+ (i./ 4 years-of-era)) + (i.- (i./ 100 years-of-era))))) + day-time (../d;frame ../d;day offset) + days-of-year (if (../d/>= ../d;empty day-time) + days-of-year + (i.dec days-of-year)) + mp (|> days-of-year (i.* 5) (i.+ 2) (i./ 153)) + day (|> days-of-year + (i.- (|> mp (i.* 153) (i.+ 2) (i./ 5))) + (i.+ 1)) + month (|> mp + (i.+ (if (i.< 10 mp) + 3 + -9))) + year (if (i.<= 2 month) + (i.inc year) + year)] + [[year month day] + day-time])) + +## Based on this: https://stackoverflow.com/a/42936293/6823464 +(def: (encode instant) + (-> Instant Text) + (let [[[year month day] day-time] (extract-date instant) + day-time (if (../d/>= ../d;empty day-time) + day-time + (../d;merge ../d;day day-time)) + [hours day-time] [(../d;query ../d;hour day-time) (../d;frame ../d;hour day-time)] + [minutes day-time] [(../d;query ../d;minute day-time) (../d;frame ../d;minute day-time)] + [seconds millis] [(../d;query ../d;second day-time) (../d;frame ../d;second day-time)] + ] + (format (%i year) "-" (pad month) "-" (pad day) "T" + (pad hours) ":" (pad minutes) ":" (pad seconds) + (|> millis + (adjust-negative ../d;second) + ../d;to-millis + encode-millis) + "Z"))) + +## Codec::decode +(def: lex-year + (l;Lexer Int) + (do p;Monad<Parser> + [sign? (p;opt (l;this "-")) + raw-year (l;codec number;Codec<Text,Int> (l;many l;decimal)) + #let [signum (case sign? + #;None 1 + (#;Some _) -1)]] + (wrap (i.* signum raw-year)))) + +(def: lex-section + (l;Lexer Int) + (l;codec number;Codec<Text,Int> (l;exactly +2 l;decimal))) + +(def: lex-millis + (l;Lexer Int) + (p;either (|> (l;at-most +3 l;decimal) + (l;codec number;Codec<Text,Int>) + (p;after (l;this "."))) + (:: p;Monad<Parser> wrap 0))) + +(def: (leap-years year) + (-> Int Int) + (|> (i./ 4 year) + (i.- (i./ 100 year)) + (i.+ (i./ 400 year)))) + +## Based on: https://stackoverflow.com/a/3309340/6823464 +(def: lex-instant + (l;Lexer Instant) + (do p;Monad<Parser> + [utc-year lex-year + _ (l;this "-") + utc-month lex-section + _ (p;assert "Invalid month." + (and (i.>= 1 utc-month) + (i.<= 12 utc-month))) + #let [months (if (leap-year? utc-year) + leap-year-months + normal-months) + month-days (|> months + (v;nth (int-to-nat (i.dec utc-month))) + assume)] + _ (l;this "-") + utc-day lex-section + _ (p;assert "Invalid day." + (and (i.>= 1 utc-day) + (i.<= (nat-to-int month-days) utc-day))) + _ (l;this "T") + utc-hour lex-section + _ (p;assert "Invalid hour." + (and (i.>= 0 utc-hour) + (i.<= 23 utc-hour))) + _ (l;this ":") + utc-minute lex-section + _ (p;assert "Invalid minute." + (and (i.>= 0 utc-minute) + (i.<= 59 utc-minute))) + _ (l;this ":") + utc-second lex-section + _ (p;assert "Invalid second." + (and (i.>= 0 utc-second) + (i.<= 59 utc-second))) + utc-millis lex-millis + _ (l;this "Z") + #let [years-since-epoch (i.- epoch-year utc-year) + previous-leap-days (i.- (leap-years epoch-year) + (leap-years (i.dec utc-year))) + year-days-so-far (|> (i.* 365 years-since-epoch) + (i.+ previous-leap-days)) + month-days-so-far (|> months + v;to-list + (list;take (int-to-nat (i.dec utc-month))) + (L/fold n.+ +0)) + total-days (|> year-days-so-far + (i.+ (nat-to-int month-days-so-far)) + (i.+ (i.dec utc-day)))]] + (wrap (|> epoch + (shift (../d;scale total-days ../d;day)) + (shift (../d;scale utc-hour ../d;hour)) + (shift (../d;scale utc-minute ../d;minute)) + (shift (../d;scale utc-second ../d;second)) + (shift (../d;scale utc-millis ../d;milli)))))) + +(def: (decode input) + (-> Text (R;Result Instant)) + (l;run input lex-instant)) + +(struct: #export _ + {#;doc "Based on ISO 8601. + + For example: 2017-01-15T21:14:51.827Z"} + (Codec Text Instant) + (def: encode encode) + (def: decode decode)) + +(def: #export now + (IO Instant) + (io (from-millis (_lux_proc ["io" "current-time"] [])))) |