aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/test.lux16
-rw-r--r--stdlib/source/lux/time/duration.lux70
-rw-r--r--stdlib/source/lux/time/instant.lux (renamed from stdlib/source/lux/time.lux)241
3 files changed, 202 insertions, 125 deletions
diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux
index eabfe9811..5d95e2f6b 100644
--- a/stdlib/source/lux/test.lux
+++ b/stdlib/source/lux/test.lux
@@ -14,13 +14,11 @@
text/format
["E" result])
[io #- run]
+ (time [instant]
+ [duration])
["R" math/random]))
## [Host]
-(def: now
- (IO Int)
- (io (_lux_proc ["io" "current-time"] [])))
-
(do-template [<name> <signal>]
[(def: #hidden <name> (IO Bottom)
(io (_lux_proc ["io" "exit"] [<signal>])))]
@@ -63,10 +61,12 @@
(L/map (: (-> [Text (IO Test) Text] (Promise Counters))
(function [[module test description]]
(do @
- [#let [pre (io;run now)]
+ [#let [pre (io;run instant;now)]
[counters documentation] (io;run test)
- #let [post (io;run now)
- _ (log! (format "@ " module " (" (%i (i.- pre post)) "ms" ") " "\n"
+ #let [post (io;run instant;now)
+ _ (log! (format "@ " module " "
+ "(" (%i (duration;to-millis (instant;span pre post))) "ms" ")"
+ "\n"
description "\n"
"\n" documentation "\n"))]]
(wrap counters)))))
@@ -112,7 +112,7 @@
(def: #hidden (repeat ?seed times random-test)
(-> (Maybe Nat) Nat (R;Random Test) Test)
- (repeat' (default (int-to-nat (io;run now))
+ (repeat' (default (|> (io;run instant;now) instant;to-millis int-to-nat)
?seed)
(case ?seed
#;None times
diff --git a/stdlib/source/lux/time/duration.lux b/stdlib/source/lux/time/duration.lux
new file mode 100644
index 000000000..3deefa944
--- /dev/null
+++ b/stdlib/source/lux/time/duration.lux
@@ -0,0 +1,70 @@
+(;module:
+ lux
+ (lux (control eq
+ order)
+ (type model)))
+
+(model: #export Duration
+ {#;doc "Durations have a resolution of milliseconds."}
+ Int
+
+ (def: #export from-millis
+ (-> Int Duration)
+ (|>. @model))
+
+ (def: #export to-millis
+ (-> Duration Int)
+ (|>. @repr))
+
+ (do-template [<name> <op>]
+ [(def: #export (<name> param subject)
+ (-> Duration Duration Duration)
+ (@model (<op> (@repr param) (@repr subject))))]
+
+ [merge i.+]
+ [frame i.%]
+ )
+
+ (def: #export (scale scalar duration)
+ (-> Int Duration Duration)
+ (@model (i.* scalar (@repr duration))))
+
+ (def: #export (query param subject)
+ (-> Duration Duration Int)
+ (i./ (@repr param) (@repr subject)))
+
+ (struct: #export _ (Eq Duration)
+ (def: (= param subject)
+ (i.= (@repr param) (@repr subject))))
+
+ (struct: #export _ (Order Duration)
+ (def: eq Eq<Duration>)
+ (do-template [<name> <op>]
+ [(def: (<name> param subject)
+ (<op> (@repr param) (@repr subject)))]
+
+ [< i.<]
+ [<= i.<=]
+ [> i.>]
+ [>= i.>=]
+ ))
+
+ (do-template [<name> <op>]
+ [(def: #export (<name> duration)
+ (-> Duration Bool)
+ (<op> 0 (@repr duration)))]
+
+ [positive? i.>]
+ [negative? i.<]
+ [neutral? i.=])
+ )
+
+(def: #export empty Duration (from-millis 0))
+(def: #export milli Duration (from-millis 1))
+(def: #export second Duration (from-millis 1_000))
+(def: #export minute Duration (scale 60 second))
+(def: #export hour Duration (scale 60 minute))
+(def: #export day Duration (scale 24 hour))
+(def: #export week Duration (scale 7 day))
+(def: #export normal-year Duration (scale 365 day))
+(def: #export leap-year Duration (merge day normal-year))
diff --git a/stdlib/source/lux/time.lux b/stdlib/source/lux/time/instant.lux
index d910287f7..0e9fc22f6 100644
--- a/stdlib/source/lux/time.lux
+++ b/stdlib/source/lux/time/instant.lux
@@ -1,7 +1,7 @@
(;module:
lux
- (lux (control enum
- eq
+ (lux [io #- run]
+ (control eq
order
codec
[monad #+ do Monad]
@@ -12,48 +12,59 @@
[number]
["R" result]
(coll [list "L/" Fold<List> Functor<List>]
- ["v" vector "v/" Functor<Vector> Fold<Vector>]))))
+ ["v" vector "v/" Functor<Vector> Fold<Vector>]))
+ (type model))
+ (.. ["../d" duration "../d/" ;Order<Duration>]))
-(type: #export Time
- {#;doc "Time is defined as milliseconds since the epoch."}
- Int)
+(model: #export Instant
+ {#;doc "Instant 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]
- )
+ (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 Time)
- (def: = t.=))
+ (struct: #export _ (Eq Instant)
+ (def: (= param subject)
+ (i.= (@repr param) (@repr subject))))
-(struct: #export _ (Order Time)
- (def: eq Eq<Time>)
- (def: < t.<)
- (def: <= t.<=)
- (def: > t.>)
- (def: >= t.>=))
+ (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)
@@ -68,51 +79,47 @@
(def: epoch-year Int 1970)
-(def: (positive? time)
- (-> Time Bool)
- (i.>= 0 time))
-
(def: (find-year now)
- (-> Time [Int Time])
+ (-> Instant [Int ../d;Duration])
(loop [reference epoch-year
- time-left now]
+ time-left (relative 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?
+ ../d;leap-year
+ ../d;normal-year)]
+ (if (i.= 0 (../d;query year time-left))
[reference time-left]
- (if (positive? time-left)
- (recur (i.inc reference) (i.- year time-left))
- (recur (i.dec reference) (i.+ year 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 Time)
- (v/map (i.* day)
- (v;vector 31 28 31
- 30 31 30
- 31 31 30
- 31 30 31)))
+ (v;Vector Nat)
+ (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))
+ (v;Vector Nat)
+ (v;update [+1] n.inc 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]
+ (-> (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-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/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)
@@ -121,31 +128,27 @@
(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: (adjust-negative space duration)
+ (-> ../d;Duration ../d;Duration ../d;Duration)
+ (if (../d;negative? duration)
+ (../d;merge space duration)
+ duration))
(def: (encode-millis millis)
- (-> Time Text)
+ (-> 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 (i./ second day))
+(def: seconds-per-day Int (../d;query ../d;second ../d;day))
(def: days-up-to-epoch Int 719468)
-(def: (extract-date time)
- (-> Time [[Int Int Int] Time])
- (let [seconds (i./ second time)
+(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)
@@ -162,8 +165,8 @@
(i.- (|> (i.* 365 years-of-era)
(i.+ (i./ 4 years-of-era))
(i.- (i./ 100 years-of-era)))))
- day-time (i.% ;;day time)
- days-of-year (if (positive? day-time)
+ 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))
@@ -181,19 +184,21 @@
day-time]))
## Based on this: https://stackoverflow.com/a/42936293/6823464
-(def: (encode time)
- (-> Time Text)
- (let [[[year month day] time] (extract-date time)
- time (if (positive? time)
- time
- (i.+ time ;;day))
- [hours time] [(i./ hour time) (i.% hour time)]
- [minutes time] [(i./ minute time) (i.% minute time)]
- [seconds millis] [(i./ second time) (i.% second time)]]
+(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 second)
+ (adjust-negative ../d;second)
+ ../d;to-millis
encode-millis)
"Z")))
@@ -226,8 +231,8 @@
(i.+ (i./ 400 year))))
## Based on: https://stackoverflow.com/a/3309340/6823464
-(def: lex-time
- (l;Lexer Time)
+(def: lex-instant
+ (l;Lexer Instant)
(do p;Monad<Parser>
[utc-year lex-year
_ (l;this "-")
@@ -240,13 +245,12 @@
normal-months)
month-days (|> months
(v;nth (int-to-nat (i.dec utc-month)))
- assume
- (i./ day))]
+ assume)]
_ (l;this "-")
utc-day lex-section
_ (p;assert "Invalid day."
(and (i.>= 1 utc-day)
- (i.<= month-days utc-day)))
+ (i.<= (nat-to-int month-days) utc-day)))
_ (l;this "T")
utc-hour lex-section
_ (p;assert "Invalid hour."
@@ -272,26 +276,29 @@
month-days-so-far (|> months
v;to-list
(list;take (int-to-nat (i.dec utc-month)))
- (L/fold i.+ 0)
- (i./ day))
+ (L/fold n.+ +0))
total-days (|> year-days-so-far
- (i.+ month-days-so-far)
+ (i.+ (nat-to-int month-days-so-far))
(i.+ (i.dec utc-day)))]]
- (wrap ($_ t.+
- (i.* day total-days)
- (i.* hour utc-hour)
- (i.* minute utc-minute)
- (i.* second utc-second)
- utc-millis))))
+ (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 Time))
- (l;run input lex-time))
+ (-> 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 Time)
+ (Codec Text Instant)
(def: encode encode)
(def: decode decode))
+
+(def: #export now
+ (IO Instant)
+ (io (from-millis (_lux_proc ["io" "current-time"] []))))