aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2017-07-24 20:04:59 -0400
committerEduardo Julian2017-07-24 20:04:59 -0400
commitb86a223c911edf2580b46d9892f344531616695d (patch)
tree4a8653a1a1295fbb02ce3f480274ab24dc8a5fef
parent6928bc80cfc265628215b0111751e072f6f2e640 (diff)
- Refactored Time into Instant and Duration.
-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
-rw-r--r--stdlib/test/test/lux/time.lux68
-rw-r--r--stdlib/test/test/lux/time/duration.lux57
-rw-r--r--stdlib/test/test/lux/time/instant.lux74
-rw-r--r--stdlib/test/tests.lux3
7 files changed, 335 insertions, 194 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"] []))))
diff --git a/stdlib/test/test/lux/time.lux b/stdlib/test/test/lux/time.lux
deleted file mode 100644
index 3d477f4ea..000000000
--- a/stdlib/test/test/lux/time.lux
+++ /dev/null
@@ -1,68 +0,0 @@
-(;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: boundary Int 99_999_999_999_999)
-
-(def: time (r;Random @;Time)
- (|> r;int (:: 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 +16366082068080165840
- [sample time
- #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/test/lux/time/duration.lux b/stdlib/test/test/lux/time/duration.lux
new file mode 100644
index 000000000..18ec46090
--- /dev/null
+++ b/stdlib/test/test/lux/time/duration.lux
@@ -0,0 +1,57 @@
+(;module:
+ lux
+ (lux [io]
+ (control [monad #+ do Monad])
+ (math ["r" random])
+ (time ["@" duration]))
+ lux/test)
+
+(def: duration
+ (r;Random @;Duration)
+ (|> r;int (:: r;Monad<Random> map @;from-millis)))
+
+(context: "Conversion."
+ [millis r;int]
+ (test "Can convert from/to milliseconds."
+ (|> millis @;from-millis @;to-millis (i.= millis))))
+
+(context: "Equality"
+ [sample duration
+ #let [(^open "@/") @;Eq<Duration>]]
+ (test "Every duration equals itself."
+ (@/= sample sample)))
+
+(context: "Order"
+ [reference duration
+ sample duration
+ #let [(^open "@/") @;Order<Duration>]]
+ (test "Can compare times."
+ (and (or (@/< reference sample)
+ (@/>= reference sample))
+ (or (@/> reference sample)
+ (@/<= reference sample)))))
+
+(context: "Arithmetic."
+ #seed +16674263968423793
+ [sample (|> duration (:: @ map (@;frame @;day)))
+ frame duration
+ factor (|> r;int (:: @ map (|>. (i.% 10) (i.max 1))))
+ #let [(^open "@/") @;Order<Duration>]]
+ ($_ seq
+ (test "Can scale a duration."
+ (|> sample (@;scale factor) (@;query sample) (i.= factor)))
+ (test "Scaling a duration by one does not change it."
+ (|> sample (@;scale 1) (@/= sample)))
+ (test "Merging with the empty duration changes nothing."
+ (|> sample (@;merge @;empty) (@/= sample)))
+ (test "Merging a duration with it's opposite yields an empty duration."
+ (|> sample (@;merge (@;scale -1 sample)) (@/= @;empty)))
+ (test "Can frame a duration in terms of another."
+ (if (or (and (@;positive? frame) (@;positive? sample))
+ (and (@;negative? frame) (@;negative? sample)))
+ (|> sample (@;frame frame) (@/< frame))
+ (or (or (@;neutral? frame) (@;neutral? sample))
+ (|> sample (@;frame frame) (@;scale -1) (@/< (if (@;negative? frame)
+ (@;scale -1 frame)
+ frame))))))
+ ))
diff --git a/stdlib/test/test/lux/time/instant.lux b/stdlib/test/test/lux/time/instant.lux
new file mode 100644
index 000000000..eda4e4ebe
--- /dev/null
+++ b/stdlib/test/test/lux/time/instant.lux
@@ -0,0 +1,74 @@
+(;module:
+ lux
+ (lux [io]
+ (control [monad #+ do Monad]
+ pipe)
+ (data [text]
+ text/format
+ ["R" result]
+ [number "Int/" Number<Int>])
+ (math ["r" random])
+ (time ["@" instant]
+ ["@d" duration]))
+ lux/test)
+
+(def: boundary Int 99_999_999_999_999)
+
+(def: instant
+ (r;Random @;Instant)
+ (|> r;int (:: r;Monad<Random> map (|>. (i.% boundary) @;from-millis))))
+
+(def: duration
+ (r;Random @d;Duration)
+ (|> r;int (:: r;Monad<Random> map @d;from-millis)))
+
+(context: "Conversion."
+ [millis r;int]
+ (test "Can convert from/to milliseconds."
+ (|> millis @;from-millis @;to-millis (i.= millis))))
+
+(context: "Equality"
+ [sample instant
+ #let [(^open "@/") @;Eq<Instant>]]
+ (test "Every instant equals itself."
+ (@/= sample sample)))
+
+(context: "Order"
+ [reference instant
+ sample instant
+ #let [(^open "@/") @;Order<Instant>]]
+ (test "Can compare instants."
+ (and (or (@/< reference sample)
+ (@/>= reference sample))
+ (or (@/> reference sample)
+ (@/<= reference sample)))))
+
+(context: "Arithmetic"
+ [sample instant
+ span duration
+ #let [(^open "@/") @;Eq<Instant>
+ (^open "@d/") @d;Eq<Duration>]]
+ ($_ seq
+ (test "The span of a instant and itself has an empty duration."
+ (|> sample (@;span sample) (@d/= @d;empty)))
+ (test "Can shift a instant by a duration."
+ (|> sample (@;shift span) (@;span sample) (@d/= span)))
+ (test "Can obtain the time-span between the epoch and an instant."
+ (|> sample @;relative @;absolute (@/= sample)))
+ (test "All instants are relative to the epoch."
+ (|> @;epoch (@;shift (@;relative sample)) (@/= sample)))))
+
+(context: "Codec"
+ #seed +4428624921609897635
+ [sample instant
+ #let [(^open "@/") @;Eq<Instant>
+ (^open "@/") @;Codec<Text,Instant>]]
+ (test "Can encode/decode instants."
+ (|> sample
+ @/encode
+ @/decode
+ (case> (#R;Success decoded)
+ (@/= sample decoded)
+
+ (#R;Error error)
+ false))))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index 7c8258bc6..3004190c1 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -9,7 +9,8 @@
(lux ["_;" cli]
["_;" host]
["_;" io]
- ["_;" time]
+ (time ["_;" instant]
+ ["_;" duration])
(concurrency ["_;" actor]
["_;" atom]
["_;" frp]