aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--stdlib/source/lux/time/date.lux137
-rw-r--r--stdlib/source/lux/time/duration.lux74
-rw-r--r--stdlib/test/test/lux/time/date.lux45
-rw-r--r--stdlib/test/test/lux/time/duration.lux18
4 files changed, 268 insertions, 6 deletions
diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux
index 20f29e943..bd7253a59 100644
--- a/stdlib/source/lux/time/date.lux
+++ b/stdlib/source/lux/time/date.lux
@@ -2,7 +2,15 @@
lux
(lux (control eq
order
- enum)))
+ enum
+ codec
+ ["p" parser]
+ [monad #+ do])
+ (data ["R" result]
+ [number "int/" Codec<Text,Int>]
+ [text "text/" Monoid<Text>]
+ (text ["l" lexer])
+ (coll ["v" vector]))))
(type: #export Year Int)
@@ -185,3 +193,130 @@
(get@ #month sample))
(n.= (get@ #day reference)
(get@ #day sample)))))
+
+(def: (date.< reference sample)
+ (-> Date Date Bool)
+ (or (i.< (get@ #year reference)
+ (get@ #year sample))
+ (:: Order<Month> <
+ (get@ #month reference)
+ (get@ #month sample))
+ (n.< (get@ #day reference)
+ (get@ #day sample))))
+
+(struct: #export _ (Order Date)
+ (def: eq Eq<Date>)
+ (def: < date.<)
+ (def: (> reference sample)
+ (date.< sample reference))
+ (def: (<= reference sample)
+ (or (date.< reference sample)
+ (:: Eq<Date> = reference sample)))
+ (def: (>= reference sample)
+ (or (date.< sample reference)
+ (:: Eq<Date> = sample reference))))
+
+## Based on this: https://stackoverflow.com/a/42936293/6823464
+(def: (pad value)
+ (-> Int Text)
+ (if (i.< 10 value)
+ (text/append "0" (int/encode value))
+ (int/encode value)))
+
+(def: (encode [year month day])
+ (-> Date Text)
+ ($_ text/append
+ (int/encode year) "-"
+ (pad (|> month month-to-nat n.inc nat-to-int)) "-"
+ (pad (|> day nat-to-int))))
+
+(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: (leap-years year)
+ (-> Int Int)
+ (|> (i./ 4 year)
+ (i.- (i./ 100 year))
+ (i.+ (i./ 400 year))))
+
+(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: (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))))
+
+## Based on: https://stackoverflow.com/a/3309340/6823464
+(def: lex-date
+ (l;Lexer Date)
+ (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)))]
+ (wrap {#year utc-year
+ #month (case utc-month
+ 1 #January
+ 2 #February
+ 3 #March
+ 4 #April
+ 5 #May
+ 6 #June
+ 7 #July
+ 8 #August
+ 9 #September
+ 10 #October
+ 11 #November
+ 12 #December
+ _ (undefined))
+ #day (int-to-nat utc-day)})))
+
+(def: (decode input)
+ (-> Text (R;Result Date))
+ (l;run input lex-date))
+
+(struct: #export _
+ {#;doc "Based on ISO 8601.
+
+ For example: 2017-01-15"}
+ (Codec Text Date)
+ (def: encode encode)
+ (def: decode decode))
diff --git a/stdlib/source/lux/time/duration.lux b/stdlib/source/lux/time/duration.lux
index 3deefa944..2f3d019dd 100644
--- a/stdlib/source/lux/time/duration.lux
+++ b/stdlib/source/lux/time/duration.lux
@@ -1,7 +1,14 @@
(;module:
lux
(lux (control eq
- order)
+ order
+ codec
+ ["p" parser]
+ [monad #+ do])
+ (data [number "int/" Codec<Text,Int> Number<Int>]
+ [text "text/" Monoid<Text>]
+ (text ["l" lexer])
+ ["R" result])
(type model)))
(model: #export Duration
@@ -68,3 +75,68 @@
(def: #export week Duration (scale 7 day))
(def: #export normal-year Duration (scale 365 day))
(def: #export leap-year Duration (merge day normal-year))
+
+(def: (encode duration)
+ (-> Duration Text)
+ (if (:: Eq<Duration> = empty duration)
+ "0ms"
+ (let [signed? (negative? duration)
+ [hours time-left] [(query hour duration) (frame hour duration)]
+ hours (if signed?
+ (int/abs hours)
+ hours)
+ time-left (if signed?
+ (scale -1 time-left)
+ time-left)
+ [minutes time-left] [(query minute time-left) (frame minute time-left)]
+ [seconds time-left] [(query second time-left) (frame second time-left)]
+ millis (to-millis time-left)]
+ ($_ text/append
+ (if signed? "-" "")
+ (if (i.= 0 hours) "" (text/append (int/encode hours) "h"))
+ (if (i.= 0 minutes) "" (text/append (int/encode minutes) "m"))
+ (if (i.= 0 seconds) "" (text/append (int/encode seconds) "s"))
+ (if (i.= 0 millis) "" (text/append (int/encode millis) "ms"))
+ ))))
+
+(def: (lex-section suffix)
+ (-> Text (l;Lexer Int))
+ (|> (l;codec number;Codec<Text,Int> (l;many l;decimal))
+ (p;before (l;this suffix))
+ (p;default 0)))
+
+(def: lex-duration
+ (l;Lexer Duration)
+ (do p;Monad<Parser>
+ [signed? (l;this? "-")
+ #let [sign (function [raw] (if signed? (i.* -1 raw) raw))]
+ utc-hour (lex-section "h")
+ utc-minute (lex-section "m")
+ _ (p;assert "Invalid minute."
+ (and (i.>= 0 utc-minute)
+ (i.<= 59 utc-minute)))
+ utc-second (lex-section "s")
+ _ (p;assert "Invalid second."
+ (and (i.>= 0 utc-second)
+ (i.<= 59 utc-second)))
+ utc-millis (lex-section "ms")
+ _ (p;assert "Invalid milli-seconds."
+ (and (i.>= 0 utc-millis)
+ (i.<= 999 utc-millis)))]
+ (wrap (|> empty
+ (merge (scale (sign utc-hour) hour))
+ (merge (scale (sign utc-minute) minute))
+ (merge (scale (sign utc-second) second))
+ (merge (scale (sign utc-millis) milli))))))
+
+(def: (decode input)
+ (-> Text (R;Result Duration))
+ (l;run input lex-duration))
+
+(struct: #export _
+ {#;doc "Based on ISO 8601.
+
+ For example: 21h14m51s827ms"}
+ (Codec Text Duration)
+ (def: encode encode)
+ (def: decode decode))
diff --git a/stdlib/test/test/lux/time/date.lux b/stdlib/test/test/lux/time/date.lux
index e5b5fefc5..2a56fb71a 100644
--- a/stdlib/test/test/lux/time/date.lux
+++ b/stdlib/test/test/lux/time/date.lux
@@ -1,10 +1,14 @@
(;module:
lux
(lux [io]
- (control [monad #+ do Monad])
+ (control [monad #+ do Monad]
+ [pipe])
+ (data ["R" result])
(math ["r" random "r/" Monad<Random>])
- (time ["@" date]))
- lux/test)
+ (time ["@;" instant]
+ ["@" date]))
+ lux/test
+ (test (lux (time ["_;" instant]))))
(def: month
(r;Random @;Month)
@@ -84,3 +88,38 @@
sample))
(|> sample @/succ @/pred (@/= sample))
(|> sample @/pred @/succ (@/= sample)))))
+
+(def: date
+ (r;Random @;Date)
+ (|> _instant;instant (:: r;Monad<Random> map @instant;date)))
+
+(context: "(Date) Eq."
+ [sample date
+ #let [(^open "@/") @;Eq<Date>]]
+ (test "Every value equals itself."
+ (@/= sample sample)))
+
+(context: "(Date) Order."
+ [reference date
+ sample date
+ #let [(^open "@/") @;Order<Date>]]
+ (test "Valid Order."
+ (and (or (@/< reference sample)
+ (@/>= reference sample))
+ (or (@/> reference sample)
+ (@/<= reference sample)))))
+
+(context: "(Date) Codec"
+ #seed +1501531301120
+ [sample date
+ #let [(^open "@/") @;Eq<Date>
+ (^open "@/") @;Codec<Text,Date>]]
+ (test "Can encode/decode dates."
+ (|> sample
+ @/encode
+ @/decode
+ (pipe;case> (#R;Success decoded)
+ (@/= sample decoded)
+
+ (#R;Error error)
+ false))))
diff --git a/stdlib/test/test/lux/time/duration.lux b/stdlib/test/test/lux/time/duration.lux
index 18ec46090..565010a07 100644
--- a/stdlib/test/test/lux/time/duration.lux
+++ b/stdlib/test/test/lux/time/duration.lux
@@ -1,7 +1,9 @@
(;module:
lux
(lux [io]
- (control [monad #+ do Monad])
+ (control [monad #+ do Monad]
+ [pipe])
+ (data ["R" result])
(math ["r" random])
(time ["@" duration]))
lux/test)
@@ -55,3 +57,17 @@
(@;scale -1 frame)
frame))))))
))
+
+(context: "Codec"
+ [sample duration
+ #let [(^open "@/") @;Eq<Duration>
+ (^open "@/") @;Codec<Text,Duration>]]
+ (test "Can encode/decode durations."
+ (|> sample
+ @/encode
+ @/decode
+ (pipe;case> (#R;Success decoded)
+ (@/= sample decoded)
+
+ (#R;Error error)
+ false))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 19:12:39 +0000