From 8ddeafb14fdb4511f2d0632801f18699cfcaf3ea Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 31 Jul 2017 20:33:00 -0400 Subject: - Extended duration and date with Order and Codec implementations. --- stdlib/source/lux/time/date.lux | 137 ++++++++++++++++++++++++++++++++- stdlib/source/lux/time/duration.lux | 74 +++++++++++++++++- stdlib/test/test/lux/time/date.lux | 45 ++++++++++- stdlib/test/test/lux/time/duration.lux | 18 ++++- 4 files changed, 268 insertions(+), 6 deletions(-) (limited to 'stdlib') 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 "text/" Monoid] + (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 < + (get@ #month reference) + (get@ #month sample)) + (n.< (get@ #day reference) + (get@ #day sample)))) + +(struct: #export _ (Order Date) + (def: eq Eq) + (def: < date.<) + (def: (> reference sample) + (date.< sample reference)) + (def: (<= reference sample) + (or (date.< reference sample) + (:: Eq = reference sample))) + (def: (>= reference sample) + (or (date.< sample reference) + (:: Eq = 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 + [sign? (p;opt (l;this "-")) + raw-year (l;codec number;Codec (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 (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 + [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 Number] + [text "text/" Monoid] + (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 = 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 (l;many l;decimal)) + (p;before (l;this suffix)) + (p;default 0))) + +(def: lex-duration + (l;Lexer Duration) + (do p;Monad + [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]) - (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 map @instant;date))) + +(context: "(Date) Eq." + [sample date + #let [(^open "@/") @;Eq]] + (test "Every value equals itself." + (@/= sample sample))) + +(context: "(Date) Order." + [reference date + sample date + #let [(^open "@/") @;Order]] + (test "Valid Order." + (and (or (@/< reference sample) + (@/>= reference sample)) + (or (@/> reference sample) + (@/<= reference sample))))) + +(context: "(Date) Codec" + #seed +1501531301120 + [sample date + #let [(^open "@/") @;Eq + (^open "@/") @;Codec]] + (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 + (^open "@/") @;Codec]] + (test "Can encode/decode durations." + (|> sample + @/encode + @/decode + (pipe;case> (#R;Success decoded) + (@/= sample decoded) + + (#R;Error error) + false)))) -- cgit v1.2.3