aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--stdlib/source/lux/time.lux295
-rw-r--r--stdlib/test/test/lux/time.lux86
-rw-r--r--stdlib/test/tests.lux1
3 files changed, 382 insertions, 0 deletions
diff --git a/stdlib/source/lux/time.lux b/stdlib/source/lux/time.lux
new file mode 100644
index 000000000..89c01b0ea
--- /dev/null
+++ b/stdlib/source/lux/time.lux
@@ -0,0 +1,295 @@
+(;module:
+ lux
+ (lux (control enum
+ 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: #export Time
+ {#;doc "Time is defined as milliseconds since the epoch."}
+ Int)
+
+(def: #export epoch
+ {#;doc "The time corresponding to 1970-01-01T00:00:00Z"}
+ Time
+ 0)
+
+(def: #export second Time 1_000)
+(def: #export minute Time (i.* 60 second))
+(def: #export hour Time (i.* 60 minute))
+(def: #export day Time (i.* 24 hour))
+(def: #export week Time (i.* 7 day))
+(def: #export normal-year Time (i.* 365 day))
+(def: #export leap-year Time (i.+ day normal-year))
+
+(do-template [<name> <op> <output>]
+ [(def: #export (<name> param subject)
+ (-> Time Time <output>)
+ (<op> param subject))]
+
+ [t.+ i.+ Time]
+ [t.- i.- Time]
+ [t.= i.= Bool]
+ [t.< i.< Bool]
+ [t.<= i.<= Bool]
+ [t.> i.> Bool]
+ [t.>= i.>= Bool]
+ )
+
+(struct: #export _ (Eq Time)
+ (def: = t.=))
+
+(struct: #export _ (Order Time)
+ (def: eq Eq<Time>)
+ (def: < t.<)
+ (def: <= t.<=)
+ (def: > t.>)
+ (def: >= t.>=))
+
+## 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: (positive? time)
+ (-> Time Bool)
+ (i.>= 0 time))
+
+(def: (find-year now)
+ (-> Time [Int Time])
+ (loop [reference epoch-year
+ time-left now]
+ (let [year (if (leap-year? reference)
+ leap-year
+ normal-year)
+ within-year-time-frame? (|> time-left (i.% year) (i.= time-left))]
+ (if within-year-time-frame?
+ [reference time-left]
+ (if (positive? time-left)
+ (recur (i.inc reference) (i.- year time-left))
+ (recur (i.dec reference) (i.+ year time-left)))
+ ))))
+
+(def: normal-months
+ (v;Vector Time)
+ (v/map (i.* day)
+ (v;vector 31 28 31
+ 30 31 30
+ 31 31 30
+ 31 30 31)))
+
+(def: leap-year-months
+ (v;Vector Time)
+ (v;update [+1] (i.+ day) normal-months))
+
+(def: (find-month months time)
+ (-> (v;Vector Time) Time [Int Time])
+ (if (positive? time)
+ (v/fold (function [month-time [current-month time-left]]
+ (if (|> time-left (i.% month-time) (i.= time-left))
+ [current-month time-left]
+ [(i.inc current-month) (i.- month-time time-left)]))
+ [0 time]
+ months)
+ (v/fold (function [month-time [current-month time-left]]
+ (if (|> time-left (i.% month-time) (i.= time-left))
+ [current-month time-left]
+ [(i.dec current-month) (i.+ month-time time-left)]))
+ [11 time]
+ (v;reverse months))))
+
+(def: (pad value)
+ (-> Int Text)
+ (if (i.< 10 value)
+ (text/append "0" (%i value))
+ (%i value)))
+
+(def: (segment frame time)
+ (-> Time Time [Int Time])
+ [(i./ frame time)
+ (i.% frame time)])
+
+(def: (adjust-negative space value)
+ (-> Int Int Int)
+ (if (i.>= 0 value)
+ value
+ (i.+ space value)))
+
+(def: (encode-millis millis)
+ (-> Time 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: (extract-date time)
+ (-> Time [[Int Int Int] Time])
+ (let [seconds (i./ second time)
+ z (|> seconds (i./ 86400) (i.+ 719468))
+ 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)))))
+ 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]
+ (i.% ;;day time)]))
+
+## Based on this: https://stackoverflow.com/a/42936293/6823464
+(def: (encode time)
+ (-> Time Text)
+ (let [[[year month day] time] (extract-date time)
+ [hours time] [(i./ hour time) (i.% hour time)]
+ [minutes time] [(i./ minute time) (i.% minute time)]
+ [seconds millis] [(i./ second time) (i.% second time)]]
+ (format (%i year) "-" (pad month) "-" (pad day) "T"
+ (pad hours) ":" (pad minutes) ":" (pad seconds)
+ (|> millis
+ (adjust-negative second)
+ 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))))
+
+(def: lex-time
+ (l;Lexer Time)
+ (do p;Monad<Parser>
+ [utc-year lex-year
+ ## #let [_ (log! (format " utc-year = " (%i utc-year)))]
+ _ (l;this "-")
+ utc-month lex-section
+ _ (p;assert "Invalid month."
+ (and (i.>= 1 utc-month)
+ (i.<= 12 utc-month)))
+ ## #let [_ (log! (format " utc-month = " (%i 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
+ (i./ day))]
+ _ (l;this "-")
+ utc-day lex-section
+ _ (p;assert "Invalid day."
+ (and (i.>= 1 utc-day)
+ (i.<= month-days utc-day)))
+ ## #let [_ (log! (format " utc-day = " (%i utc-day)))]
+ _ (l;this "T")
+ utc-hour lex-section
+ _ (p;assert "Invalid hour."
+ (and (i.>= 0 utc-hour)
+ (i.<= 23 utc-hour)))
+ ## #let [_ (log! (format " utc-hour = " (%i utc-hour)))]
+ _ (l;this ":")
+ utc-minute lex-section
+ _ (p;assert "Invalid minute."
+ (and (i.>= 0 utc-minute)
+ (i.<= 59 utc-minute)))
+ ## #let [_ (log! (format "utc-minute = " (%i utc-minute)))]
+ _ (l;this ":")
+ utc-second lex-section
+ _ (p;assert "Invalid second."
+ (and (i.>= 0 utc-second)
+ (i.<= 59 utc-second)))
+ ## #let [_ (log! (format "utc-second = " (%i utc-second)))]
+ utc-millis lex-millis
+ ## #let [_ (log! (format "utc-millis = " (%i utc-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 i.+ 0)
+ (i./ day))
+ total-days (|> year-days-so-far
+ (i.+ month-days-so-far)
+ (i.+ (i.dec utc-day)))
+ ## _ (log! (format "total-days = " (%i total-days)))
+ ]]
+ (wrap ($_ t.+
+ (i.* day total-days)
+ (i.* hour utc-hour)
+ (i.* minute utc-minute)
+ (i.* second utc-second)
+ utc-millis))))
+
+(def: (decode input)
+ (-> Text (R;Result Time))
+ (l;run input lex-time))
+
+(struct: #export _
+ {#;doc "Based on ISO 8601.
+
+ For example: 2017-01-15T21:14:51.827Z"}
+ (Codec Text Time)
+ (def: encode encode)
+ (def: decode decode))
diff --git a/stdlib/test/test/lux/time.lux b/stdlib/test/test/lux/time.lux
new file mode 100644
index 000000000..becdfc068
--- /dev/null
+++ b/stdlib/test/test/lux/time.lux
@@ -0,0 +1,86 @@
+(;module:
+ lux
+ (lux [io]
+ (control [monad #+ do Monad]
+ pipe)
+ (data [text]
+ text/format
+ ["R" result]
+ [number "Int/" Number<Int>])
+ (math ["r" random])
+ ["@" time])
+ lux/test)
+
+(def: (limited-int size)
+ (-> Nat (r;Random Int))
+ (do r;Monad<Random>
+ [sample r;int]
+ (wrap (|> sample
+ Int/abs
+ (i.% (nat-to-int size))
+ (i.* (Int/signum sample))))))
+
+(def: (pow exp base)
+ (-> Nat Int Int)
+ (case exp
+ +0 1
+ _ (loop [exp exp
+ result base]
+ (case exp
+ +1 result
+ _ (recur (n.dec exp)
+ (i.* base result))))))
+(def: boundary Int (|> 2 (pow +31) (i.* @;second)))
+
+(def: time (r;Random @;Time)
+ (|> r;int
+ (r;filter (i.>= 0))
+ ## (:: r;Monad<Random> map (i.% boundary))
+ ))
+
+(context: "Equality"
+ [sample time
+ #let [(^open) @;Eq<Time>]]
+ (test "Every time equals itself."
+ (= sample sample)))
+
+(context: "Arithmetic"
+ [subject time
+ param time]
+ ($_ seq
+ (test "Can add and subtract times."
+ (and (|> subject (@;t.+ param) (@;t.- param) (@;t.= subject))
+ (|> subject (@;t.- param) (@;t.+ param) (@;t.= subject))))
+ (test "Subtracting a time from itself results in the epoch."
+ (@;t.= @;epoch
+ (@;t.- subject subject)))
+ ))
+
+(context: "Order"
+ [reference time
+ sample time
+ #let [(^open) @;Order<Time>]]
+ (test "Can compare times."
+ (and (or (< reference sample)
+ (>= reference sample))
+ (or (> reference sample)
+ (<= reference sample))))
+ )
+
+(context: "Codec"
+ ## #seed +1484609979608
+ ## #seed +1484654273059
+ [sample time
+ ## #let [sample 1095292800_000]
+ ## #let [_ (log! (format "sample = " (%i sample)))]
+ #let [(^open "&/") @;Codec<Text,Time>]]
+ (test "Can encode/decode times."
+ (|> sample
+ &/encode
+ &/decode
+ (case> (#R;Success decoded)
+ (@;t.= sample decoded)
+
+ (#R;Error error)
+ false)))
+ )
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index 34c5c9be2..ba0da53f8 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -9,6 +9,7 @@
(lux ["_;" cli]
["_;" host]
["_;" io]
+ ["_;" time]
(concurrency ["_;" actor]
["_;" atom]
["_;" frp]
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-24 11:49:33 +0000