From 618b1ce9743bb79f1ae3375b05a394a4183b21e8 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 3 Oct 2020 12:55:45 -0400 Subject: Added deployment code to Aedifex. --- documentation/research/math.md | 4 + documentation/research/math/real numbers.md | 5 + .../paradigm/functional reactive programming.md | 4 + .../research/paradigm/probabilistic_programming.md | 1 + documentation/research/text_editor & ide.md | 1 + stdlib/source/lux/data/text.lux | 2 + stdlib/source/lux/data/text/format.lux | 22 +- stdlib/source/lux/time/date.lux | 460 +++++++++++++++------ stdlib/source/lux/time/day.lux | 15 +- stdlib/source/lux/time/duration.lux | 108 +++-- stdlib/source/lux/time/instant.lux | 349 ++++++---------- stdlib/source/lux/time/month.lux | 87 +++- stdlib/source/lux/time/year.lux | 67 +++ stdlib/source/program/aedifex.lux | 11 +- stdlib/source/program/aedifex/cli.lux | 14 +- stdlib/source/program/aedifex/command/deploy.lux | 67 +++ stdlib/source/program/aedifex/dependency.lux | 1 + stdlib/source/program/aedifex/parser.lux | 8 + stdlib/source/program/aedifex/project.lux | 7 +- stdlib/source/program/aedifex/upload.lux | 100 +++++ stdlib/source/test/lux/macro/poly/json.lux | 1 + stdlib/source/test/lux/time/date.lux | 10 +- stdlib/source/test/lux/time/duration.lux | 15 +- stdlib/source/test/lux/time/instant.lux | 17 +- 24 files changed, 928 insertions(+), 448 deletions(-) create mode 100644 documentation/research/math/real numbers.md create mode 100644 documentation/research/paradigm/functional reactive programming.md create mode 100644 stdlib/source/lux/time/year.lux create mode 100644 stdlib/source/program/aedifex/command/deploy.lux create mode 100644 stdlib/source/program/aedifex/upload.lux diff --git a/documentation/research/math.md b/documentation/research/math.md index 21916064d..9825cd8d6 100644 --- a/documentation/research/math.md +++ b/documentation/research/math.md @@ -223,6 +223,10 @@ 1. [Finite Calculus: A Tutorial for Solving Nasty Sums](https://www.cs.purdue.edu/homes/dgleich/publications/Gleich%202005%20-%20finite%20calculus.pdf) 1. http://jliszka.github.io/2013/10/24/exact-numeric-nth-derivatives.html +# Continuous Calculus + +1. [Continuous Calculus](http://www-users.math.umn.edu/~olver/ln_/cc.pdf) + # Octonion 1. http://math.ucr.edu/home/baez/octonions/ diff --git a/documentation/research/math/real numbers.md b/documentation/research/math/real numbers.md new file mode 100644 index 000000000..2daa1873b --- /dev/null +++ b/documentation/research/math/real numbers.md @@ -0,0 +1,5 @@ +# Reference + +1. https://blog.acolyer.org/2020/10/02/toward-an-api-for-the-real-numbers/ +1. [Towards an API for the real numbers](https://dl.acm.org/doi/abs/10.1145/3385412.3386037) + diff --git a/documentation/research/paradigm/functional reactive programming.md b/documentation/research/paradigm/functional reactive programming.md new file mode 100644 index 000000000..5f97ebbec --- /dev/null +++ b/documentation/research/paradigm/functional reactive programming.md @@ -0,0 +1,4 @@ +# Reference + +1. [Explicitly Comprehensible Functional Reactive Programming](https://futureofcoding.org/papers/comprehensible-frp/comprehensible-frp.pdf) + diff --git a/documentation/research/paradigm/probabilistic_programming.md b/documentation/research/paradigm/probabilistic_programming.md index d1450f794..937ab34c6 100644 --- a/documentation/research/paradigm/probabilistic_programming.md +++ b/documentation/research/paradigm/probabilistic_programming.md @@ -64,6 +64,7 @@ # Language +1. [Bean Machine: A Declarative Probabilistic Programming Language For Efficient Programmable Inference](https://pgm2020.cs.aau.dk/wp-content/uploads/2020/09/tehrani20.pdf) 1. [Reactive Probabilistic Programming](https://arxiv.org/abs/1908.07563) 1. https://hakaru-dev.github.io/ 1. http://probcomp.csail.mit.edu/venture/ diff --git a/documentation/research/text_editor & ide.md b/documentation/research/text_editor & ide.md index ab5f3f4fe..148dc60bc 100644 --- a/documentation/research/text_editor & ide.md +++ b/documentation/research/text_editor & ide.md @@ -43,6 +43,7 @@ # Reference +1. [The Piece Table - the Unsung Hero of Your Text Editor](https://darrenburns.net/posts/piece-table/) 1. [Build Your Own Text Editor](https://viewsourcecode.org/snaptoken/kilo/) 1. [It’s 2019. Why don’t we have good code editors?](https://thoughts.thorlaksson.com/2019/09/27/its-2019-why-dont-we-have-good-code-editors/) 1. [Text Editing Hates You Too](https://lord.io/blog/2019/text-editing-hates-you-too/) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index ed4b540f7..fb2bc0728 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -40,6 +40,8 @@ [34 \'' double-quote] ) +(def: #export line-feed ..new-line) + (def: #export (size x) (-> Text Nat) ("lux text size" x)) diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index 335c120be..392e3ee42 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -1,7 +1,9 @@ (.module: [lux (#- list nat int rev type) [abstract - [monad (#+ do)]] + [monad (#+ do)] + [functor + ["." contravariant]]] [control ["p" parser ["s" code (#+ Parser)]]] @@ -31,15 +33,21 @@ [syntax (#+ syntax:)]] ["." type]]) +(type: #export (Format a) + {#.doc "A way to produce readable text from values."} + (-> a Text)) + +(structure: #export functor + (contravariant.Functor Format) + + (def: (map f fb) + (|>> f fb))) + (syntax: #export (format {fragments (p.many s.any)}) {#.doc (doc "Text interpolation." (format "Static part " (text static) " does not match URI: " uri))} (wrap (.list (` ($_ "lux text concat" (~+ fragments)))))) -(type: #export (Format a) - {#.doc "A way to produce readable text from values."} - (-> a Text)) - (template [ ] [(def: #export (Format ) @@ -60,8 +68,8 @@ [hex Nat (:: nat.hex encode)] [xml xml.XML (:: xml.codec encode)] [json json.JSON (:: json.codec encode)] - [instant instant.Instant instant.to-text] - [duration duration.Duration duration.encode] + [instant instant.Instant (:: instant.codec encode)] + [duration duration.Duration (:: duration.codec encode)] [date date.Date (:: date.codec encode)] [cursor Cursor .cursor-description] ) diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux index 7fcf3e9c6..01b521ca6 100644 --- a/stdlib/source/lux/time/date.lux +++ b/stdlib/source/lux/time/date.lux @@ -4,155 +4,204 @@ [equivalence (#+ Equivalence)] [order (#+ Order)] [enum (#+ Enum)] - codec + [codec (#+ Codec)] [monad (#+ do)]] [control - ["." try] - ["p" parser ("#@." functor) - ["l" text (#+ Parser)]]] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + ["" text (#+ Parser)]]] [data + ["." maybe] + ["." text ("#@." monoid)] [number ["n" nat ("#@." decimal)] ["i" int ("#@." decimal)]] - ["." text ("#@." monoid)] [collection - ["." row (#+ Row row)]]]] + ["." list ("#@." fold)] + ["." dictionary (#+ Dictionary)]]] + [type + abstract]] ["." // #_ + ["#." year (#+ Year)] ["#." month (#+ Month)]]) -(type: #export Year Int) +(def: month-by-number + (Dictionary Nat Month) + (list@fold (function (_ month mapping) + (dictionary.put (//month.number month) month mapping)) + (dictionary.new n.hash) + //month.year)) + +(exception: #export there-is-no-year-0) + +(def: minimum-day 1) + +(def: (month-days year month) + (-> Year Month Nat) + (if (//year.leap? year) + (//month.leap-year-days month) + (//month.days month))) + +(def: (day-is-within-limits? year month day) + (-> Year Month Nat Bit) + (and (n.>= ..minimum-day day) + (n.<= (..month-days year month) day))) -(type: #export Date +(exception: #export (invalid-day {year Year} {month Month} {day Nat}) + (exception.report + ["Value" (n@encode day)] + ["Minimum" (n@encode ..minimum-day)] + ["Maximum" (n@encode (..month-days year month))] + ["Year" (i@encode year)] + ["Month" (n@encode (//month.number month))])) + +(def: (internal-year year) + (-> Year Year) + (if (i.< +0 year) + (inc year) + year)) + +(def: (external-year year) + (-> Year Year) + (if (i.> +0 year) + year + (dec year))) + +(def: (pad value) + (-> Nat Text) + (let [digits (n@encode value)] + (if (n.< 10 value) + (text@compose "0" digits) + digits))) + +(def: separator + "-") + +(abstract: #export Date {#year Year #month Month - #day Nat}) - -(structure: #export equivalence (Equivalence Date) - (def: (= reference sample) - (and (i.= (get@ #year reference) - (get@ #year sample)) - (:: //month.equivalence = - (get@ #month reference) - (get@ #month sample)) - (n.= (get@ #day reference) - (get@ #day sample))))) - -(structure: #export order (Order Date) - (def: &equivalence ..equivalence) - (def: (< reference sample) - (or (i.< (get@ #year reference) - (get@ #year sample)) + #day Nat} + + (def: #export (date year month day) + (-> Year Month Nat (Try Date)) + (case year + +0 (exception.throw ..there-is-no-year-0 []) + _ (let [year (..internal-year year)] + (if (..day-is-within-limits? year month day) + (#try.Success + (:abstraction + {#year year + #month month + #day day})) + (exception.throw ..invalid-day [year month day]))))) + + (template [ ] + [(def: #export + (-> Date ) + (|>> :representation (get@ ) ))] + + [year Year #year ..external-year] + [month Month #month (|>)] + [day-of-month Nat #day (|>)] + ) + + (structure: #export equivalence + (Equivalence Date) + + (def: (= reference sample) + (let [reference (:representation reference) + sample (:representation sample)] (and (i.= (get@ #year reference) (get@ #year sample)) - (or (:: //month.order < - (get@ #month reference) - (get@ #month sample)) - (and (:: //month.order = - (get@ #month reference) - (get@ #month sample)) - (n.< (get@ #day reference) - (get@ #day sample)))))))) - -## Based on this: https://stackoverflow.com/a/42936293/6823464 -(def: (pad value) - (-> Int Text) - (let [digits (n@encode (.nat value))] - (if (i.< +10 value) - (text@compose "0" digits) - digits))) + (:: //month.equivalence = + (get@ #month reference) + (get@ #month sample)) + (n.= (get@ #day reference) + (get@ #day sample)))))) -(def: (encode [year month day]) - (-> Date Text) - ($_ text@compose - (if (i.< +0 year) - (i@encode year) - (n@encode (.nat year))) - "-" - (pad (|> month //month.number inc .int)) "-" - (pad (|> day .inc .int)))) - -(def: lex-year - (Parser Int) - (do p.monad - [sign (p.maybe (l.this "-")) - raw-year (p.codec n.decimal (l.many l.decimal)) - #let [signum (case sign - (#.Some _) - -1 - - #.None - +1)]] - (wrap (i.* signum (.int raw-year))))) - -(def: lex-section - (Parser Int) - (p@map .int (p.codec n.decimal (l.exactly 2 l.decimal)))) - -(def: (leap-years year) - (-> Int Int) - (|> (i./ +4 year) - (i.- (i./ +100 year)) - (i.+ (i./ +400 year)))) - -(def: #export common-months - (Row Nat) - (row 31 28 31 - 30 31 30 - 31 31 30 - 31 30 31)) - -(def: #export leap-year-months - (Row Nat) - (|> common-months - (row.update 1 inc) - try.assume)) - -(def: (divisible? factor input) - (-> Int Int Bit) - (|> input (i.% factor) (i.= +0))) - -## https://en.wikipedia.org/wiki/Leap_year#Algorithm -(def: (leap-year? year) - (-> Int Bit) - (and (divisible? +4 year) - (or (not (divisible? +100 year)) - (divisible? +400 year)))) - -## Based on: https://stackoverflow.com/a/3309340/6823464 -(def: lex-date + (structure: #export order + (Order Date) + + (def: &equivalence ..equivalence) + + (def: (< reference sample) + (let [reference (:representation reference) + sample (:representation sample)] + (or (i.< (get@ #year reference) + (get@ #year sample)) + (and (i.= (get@ #year reference) + (get@ #year sample)) + (or (:: //month.order < + (get@ #month reference) + (get@ #month sample)) + (and (:: //month.order = + (get@ #month reference) + (get@ #month sample)) + (n.< (get@ #day reference) + (get@ #day sample))))))))) + ) + +(def: parse-year + (Parser Year) + (do {@ <>.monad} + [sign (<>.or (.this "-") (wrap [])) + digits (.many .decimal) + raw-year (<>.codec i.decimal (wrap (text@compose "+" digits)))] + (wrap (case sign + (#.Left _) (i.* -1 raw-year) + (#.Right _) raw-year)))) + +(def: parse-section + (Parser Nat) + (<>.codec n.decimal (.exactly 2 .decimal))) + +(def: parse-millis + (Parser Nat) + (<>.either (|> (.at-most 3 .decimal) + (<>.codec n.decimal) + (<>.after (.this "."))) + (:: <>.monad wrap 0))) + +(template [ ] + [(exception: #export ( {value Nat}) + (exception.report + ["Value" (n@encode value)] + ["Minimum" (n@encode )] + ["Maximum" (n@encode )])) + + (def: + (Parser Nat) + (do <>.monad + [value ..parse-section] + (if (and (n.>= value) + (n.<= value)) + (wrap value) + (<>.lift (exception.throw [value])))))] + + [1 12 parse-month invalid-month] + ) + +(def: #export parser (Parser Date) - (do p.monad - [utc-year lex-year - _ (l.this "-") - utc-month lex-section - month (case utc-month - +01 (wrap #//month.January) - +02 (wrap #//month.February) - +03 (wrap #//month.March) - +04 (wrap #//month.April) - +05 (wrap #//month.May) - +06 (wrap #//month.June) - +07 (wrap #//month.July) - +08 (wrap #//month.August) - +09 (wrap #//month.September) - +10 (wrap #//month.October) - +11 (wrap #//month.November) - +12 (wrap #//month.December) - _ (p.fail "Invalid month.")) - #let [months (if (leap-year? utc-year) - leap-year-months - common-months) - month-days (|> months - (row.nth (.nat (dec utc-month))) - try.assume)] - _ (l.this "-") - utc-day lex-section - _ (p.assert "Invalid day." - (and (i.>= +1 utc-day) - (i.<= (.int month-days) utc-day)))] - (wrap {#year utc-year - #month month - #day (.nat (.dec utc-day))}))) + (do <>.monad + [utc-year ..parse-year + _ (.this ..separator) + utc-month ..parse-month + _ (.this ..separator) + #let [month (maybe.assume (dictionary.get utc-month ..month-by-number))] + utc-day ..parse-section] + (<>.lift (..date utc-year month utc-day)))) + +(def: (encode value) + (-> Date Text) + (let [year (..year value)] + ($_ text@compose + (if (i.< +0 year) + (i@encode year) + (n@encode (.nat year))) + ..separator (..pad (|> value ..month //month.number)) + ..separator (..pad (..day-of-month value))))) (structure: #export codec {#.doc (doc "Based on ISO 8601." @@ -160,4 +209,149 @@ (Codec Text Date) (def: encode ..encode) - (def: decode (l.run ..lex-date))) + (def: decode (.run ..parser))) + +(def: days-per-year + 365) + +(def: days-per-leap + (|> ..days-per-year + (n.* 4) + (n.+ 1))) + +(def: days-per-century + (let [leaps-per-century (n./ //year.leap + //year.century)] + (|> //year.century + (n.* ..days-per-year) + (n.+ leaps-per-century) + (n.- 1)))) + +(def: days-per-era + (let [centuries-per-era (n./ //year.century + //year.era)] + (|> centuries-per-era + (n.* ..days-per-century) + (n.+ 1)))) + +(def: days-since-epoch + (let [years::70 70 + leaps::70 (n./ //year.leap + years::70) + days::70 (|> years::70 + (n.* ..days-per-year) + (n.+ leaps::70)) + ## The epoch is being calculated from March 1st, instead of January 1st. + january-&-february (n.+ (//month.days #//month.January) + (//month.days #//month.February))] + (|> 0 + ## 1600/01/01 + (n.+ (n.* 4 days-per-era)) + ## 1900/01/01 + (n.+ (n.* 3 days-per-century)) + ## 1970/01/01 + (n.+ days::70) + ## 1970/03/01 + (n.- january-&-february)))) + +(def: first-month-of-civil-year 3) + +(with-expansions [ +3 + +9] + (def: (internal-month civil-month) + (-> Nat Int) + (if (n.< ..first-month-of-civil-year civil-month) + (i.+ (.int civil-month)) + (i.- (.int civil-month)))) + + (def: (civil-month internal-month) + (-> Int Nat) + (.nat (if (i.< +10 internal-month) + (i.+ internal-month) + (i.- internal-month))))) + +(with-expansions [ +153 + +2 + +5] + (def: day-of-year-from-month + (-> Nat Int) + (|>> ..internal-month + (i.* ) + (i.+ ) + (i./ ))) + + (def: month-from-day-of-year + (-> Int Nat) + (|>> (i.* ) + (i.+ ) + (i./ ) + ..civil-month))) + +(def: last-era-leap-day + (.int (dec ..days-per-leap))) + +(def: last-era-day + (.int (dec ..days-per-era))) + +(def: (civil-year utc-month utc-year) + (-> Nat Year Int) + (let [utc-year (..internal-year utc-year)] + (if (n.< ..first-month-of-civil-year utc-month) + (dec utc-year) + utc-year))) + +## http://howardhinnant.github.io/date_algorithms.html +(def: #export (days date) + (-> Date Int) + (let [utc-month (|> date ..month //month.number) + civil-year (..civil-year utc-month (..year date)) + era (|> (if (i.< +0 civil-year) + (i.- (.int (dec //year.era)) + civil-year) + civil-year) + (i./ (.int //year.era))) + year-of-era (i.- (i.* (.int //year.era) + era) + civil-year) + day-of-year (|> utc-month + ..day-of-year-from-month + (i.+ (.int (dec (..day-of-month date))))) + day-of-era (|> day-of-year + (i.+ (i.* (.int ..days-per-year) year-of-era)) + (i.+ (i./ (.int //year.leap) year-of-era)) + (i.- (i./ (.int //year.century) year-of-era)))] + (|> (i.* (.int ..days-per-era) era) + (i.+ day-of-era) + (i.- (.int ..days-since-epoch))))) + +## http://howardhinnant.github.io/date_algorithms.html +(def: #export (from-days days) + (-> Int Date) + (let [days (i.+ (.int ..days-since-epoch) days) + era (|> (if (i.< +0 days) + (i.- ..last-era-day days) + days) + (i./ (.int ..days-per-era))) + day-of-era (i.- (i.* (.int ..days-per-era) era) days) + year-of-era (|> day-of-era + (i.- (i./ ..last-era-leap-day day-of-era)) + (i.+ (i./ (.int ..days-per-century) day-of-era)) + (i.- (i./ ..last-era-day day-of-era)) + (i./ (.int ..days-per-year))) + year (i.+ (i.* (.int //year.era) era) + year-of-era) + day-of-year (|> day-of-era + (i.- (i.* (.int ..days-per-year) year-of-era)) + (i.- (i./ (.int //year.leap) year-of-era)) + (i.+ (i./ (.int //year.century) year-of-era))) + month (..month-from-day-of-year day-of-year) + day (|> day-of-year + (i.- (..day-of-year-from-month month)) + (i.+ +1) + .nat) + year (if (n.< ..first-month-of-civil-year month) + (inc year) + year)] + (try.assume (..date (..external-year year) + (maybe.assume (dictionary.get month ..month-by-number)) + day)))) diff --git a/stdlib/source/lux/time/day.lux b/stdlib/source/lux/time/day.lux index caabc8797..3e7098e4c 100644 --- a/stdlib/source/lux/time/day.lux +++ b/stdlib/source/lux/time/day.lux @@ -17,7 +17,9 @@ #Friday #Saturday) -(structure: #export equivalence (Equivalence Day) +(structure: #export equivalence + (Equivalence Day) + (def: (= reference sample) (case [reference sample] (^template [] @@ -45,13 +47,19 @@ #Friday 5 #Saturday 6)) -(structure: #export order (Order Day) +(structure: #export order + (Order Day) + (def: &equivalence ..equivalence) + (def: (< reference sample) (n.< (..nat reference) (..nat sample)))) -(structure: #export enum (Enum Day) +(structure: #export enum + (Enum Day) + (def: &order ..order) + (def: (succ day) (case day #Sunday #Monday @@ -61,6 +69,7 @@ #Thursday #Friday #Friday #Saturday #Saturday #Sunday)) + (def: (pred day) (case day #Monday #Sunday diff --git a/stdlib/source/lux/time/duration.lux b/stdlib/source/lux/time/duration.lux index 550d6ba0e..53312a487 100644 --- a/stdlib/source/lux/time/duration.lux +++ b/stdlib/source/lux/time/duration.lux @@ -1,15 +1,15 @@ (.module: [lux #* [abstract - equivalence + [equivalence (#+ Equivalence)] [order (#+ Order)] - codec + [codec (#+ Codec)] [monoid (#+ Monoid)] [monad (#+ do)]] [control - ["e" try] - ["p" parser - ["l" text]]] + ["." try] + ["<>" parser + ["" text (#+ Parser)]]] [data [number ["." nat ("#@." decimal)] @@ -31,22 +31,22 @@ (-> Duration Int) (|>> :representation)) - (template [ ] + (template [ ] [(def: #export ( param subject) (-> Duration Duration Duration) (:abstraction ( (:representation param) (:representation subject))))] - [merge i.+] - [frame i.%] + [i.+ merge] + [i.% frame] ) - (template [ ] + (template [ ] [(def: #export ( scalar) (-> Nat Duration Duration) (|>> :representation ( (.int scalar)) :abstraction))] - [scale-up i.*] - [scale-down i./] + [i.* scale-up] + [i./ scale-down] ) (def: #export inverse @@ -74,32 +74,38 @@ (def: (< param subject) (i.< (:representation param) (:representation subject)))) - (template [ ] + (template [ ] [(def: #export (-> Duration Bit) (|>> :representation ( +0)))] - [positive? i.>] - [negative? i.<] - [neutral? i.=] + [i.> positive?] + [i.< negative?] + [i.= neutral?] ) ) -(def: #export empty (from-millis +0)) -(def: #export milli-second (from-millis +1)) +(def: #export empty + (..from-millis +0)) + +(def: #export milli-second + (..from-millis +1)) (template [ ] - [(def: #export (scale-up ))] + [(def: #export + (..scale-up ))] [second 1,000 milli-second] [minute 60 second] [hour 60 minute] [day 24 hour] + [week 7 day] [normal-year 365 day] ) -(def: #export leap-year (merge day normal-year)) +(def: #export leap-year + (..merge ..day ..normal-year)) (structure: #export monoid (Monoid Duration) @@ -107,9 +113,25 @@ (def: identity ..empty) (def: compose ..merge)) -(def: #export (encode duration) - (if (:: ..equivalence = empty duration) - "+0ms" +(template [ ] + [(def: )] + + ["D" day-suffix] + ["h" hour-suffix] + ["m" minute-suffix] + ["s" second-suffix] + ["ms" milli-second-suffix] + + ["+" positive-sign] + ["-" negative-sign] + ) + +(def: (encode duration) + (if (:: ..equivalence = ..empty duration) + ($_ text@compose + ..positive-sign + (nat@encode 0) + milli-second-suffix) (let [signed? (negative? duration) [days time-left] [(query day duration) (frame day duration)] days (if signed? @@ -123,10 +145,40 @@ [seconds time-left] [(query second time-left) (frame second time-left)] millis (to-millis time-left)] ($_ text@compose - (if signed? "-" "+") - (if (i.= +0 days) "" (text@compose (nat@encode (.nat days)) "D")) - (if (i.= +0 hours) "" (text@compose (nat@encode (.nat hours)) "h")) - (if (i.= +0 minutes) "" (text@compose (nat@encode (.nat minutes)) "m")) - (if (i.= +0 seconds) "" (text@compose (nat@encode (.nat seconds)) "s")) - (if (i.= +0 millis) "" (text@compose (nat@encode (.nat millis)) "ms")) + (if signed? ..negative-sign ..positive-sign) + (if (i.= +0 days) "" (text@compose (nat@encode (.nat days)) ..day-suffix)) + (if (i.= +0 hours) "" (text@compose (nat@encode (.nat hours)) ..hour-suffix)) + (if (i.= +0 minutes) "" (text@compose (nat@encode (.nat minutes)) ..minute-suffix)) + (if (i.= +0 seconds) "" (text@compose (nat@encode (.nat seconds)) ..second-suffix)) + (if (i.= +0 millis) "" (text@compose (nat@encode (.nat millis)) ..milli-second-suffix)) )))) + +(def: parser + (Parser Duration) + (let [section (: (-> Text (Parser Nat)) + (function (_ suffix) + (|> (.many .decimal) (<>.codec nat.decimal) (<>.before (.this suffix)) (<>.default 0))))] + (do <>.monad + [sign (<>.or (.this ..negative-sign) + (.this ..positive-sign)) + days (section ..day-suffix) + hours (section hour-suffix) + minutes (section ..minute-suffix) + seconds (section ..second-suffix) + millis (section ..milli-second-suffix) + #let [span (|> ..empty + (..merge (..scale-up days ..day)) + (..merge (..scale-up hours ..hour)) + (..merge (..scale-up minutes ..minute)) + (..merge (..scale-up seconds ..second)) + (..merge (..scale-up millis ..milli-second)) + )]] + (wrap (case sign + (#.Left _) (..inverse span) + (#.Right _) span))))) + +(structure: #export codec + (Codec Text Duration) + + (def: encode ..encode) + (def: decode (.run ..parser))) diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux index ba451ef18..fd842aff6 100644 --- a/stdlib/source/lux/time/instant.lux +++ b/stdlib/source/lux/time/instant.lux @@ -2,15 +2,15 @@ [lux #* [abstract [equivalence (#+ Equivalence)] - ["." order (#+ Order)] + [order (#+ Order)] [enum (#+ Enum)] - codec - [monad (#+ do Monad)]] + [codec (#+ Codec)] + [monad (#+ Monad do)]] [control [io (#+ IO io)] - ["." try (#+ Try)] - ["p" parser - ["l" text (#+ Parser)]]] + ["." exception (#+ exception:)] + ["<>" parser + ["" text (#+ Parser)]]] [data ["." maybe] [number @@ -18,15 +18,16 @@ ["i" int ("#@." decimal)]] ["." text ("#@." monoid)] [collection - ["." list ("#@." fold)] - ["." row (#+ Row row) ("#@." functor fold)]]] + ["." row] + ["." list ("#@." fold)]]] [type abstract]] [// ["." duration (#+ Duration)] - ["." date (#+ Date)] + ["." year (#+ Year)] ["." month (#+ Month)] - ["." day (#+ Day)]]) + ["." day (#+ Day)] + ["." date (#+ Date)]]) (abstract: #export Instant Int @@ -85,52 +86,7 @@ (def: #export epoch {#.doc "The instant corresponding to 1970-01-01T00:00:00Z"} Instant - (from-millis +0)) - -## Codec::encode -(def: (divisible? factor input) - (-> Int Int Bit) - (|> input (i.% factor) (i.= +0))) - -(def: (leap-year? year) - (-> Int Bit) - (and (divisible? +4 year) - (or (not (divisible? +100 year)) - (divisible? +400 year)))) - -(def: epoch-year Int +1970) - -(def: (find-year now) - (-> Instant [Int Duration]) - (loop [reference epoch-year - time-left (relative now)] - (let [year (if (leap-year? reference) - duration.leap-year - duration.normal-year)] - (if (i.= +0 (duration.query year time-left)) - [reference time-left] - (if (order.>= duration.order duration.empty time-left) - (recur (inc reference) (duration.merge (duration.inverse year) time-left)) - (recur (dec reference) (duration.merge year time-left))) - )))) - -(def: (find-month months time) - (-> (Row Nat) Duration [Nat Duration]) - (if (order.>= duration.order duration.empty time) - (row@fold (function (_ month-days [current-month time-left]) - (let [month-duration (duration.scale-up month-days duration.day)] - (if (i.= +0 (duration.query month-duration time-left)) - [current-month time-left] - [(inc current-month) (duration.merge (duration.inverse month-duration) time-left)]))) - [0 time] - months) - (row@fold (function (_ month-days [current-month time-left]) - (let [month-duration (duration.scale-up month-days duration.day)] - (if (i.= +0 (duration.query month-duration time-left)) - [current-month time-left] - [(dec current-month) (duration.merge month-duration time-left)]))) - [11 time] - (row.reverse months)))) + (..from-millis +0)) (def: (pad value) (-> Nat Text) @@ -152,194 +108,127 @@ ## (n.< 1,000 millis) ($_ text@compose "." (n@encode millis)))) -(def: seconds-per-day Int (duration.query duration.second duration.day)) -(def: days-up-to-epoch Int +719468) - -(def: (extract-date instant) - (-> Instant [[Int Int Int] Duration]) - (let [offset (relative instant) - seconds (duration.query duration.second offset) - z (|> seconds (i./ seconds-per-day) (i.+ days-up-to-epoch)) - 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))))) - day-time (duration.frame duration.day offset) - days-of-year (if (order.>= duration.order duration.empty day-time) - days-of-year - (dec days-of-year)) - 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) - (inc year) - year)] - [[year month day] - day-time])) +(def: millis-per-day + (duration.query duration.milli-second duration.day)) + +(def: (date-time instant) + (-> Instant [Date Duration]) + (let [offset (..to-millis instant) + bce? (i.< +0 offset) + [days day-time] (if bce? + (let [[days millis] (i./% ..millis-per-day offset)] + (case millis + +0 [days millis] + _ [(dec days) (i.+ ..millis-per-day millis)])) + (i./% ..millis-per-day offset))] + [(date.from-days days) + (duration.from-millis day-time)])) + +(template [ ] + [(def: Text )] + + ["T" date-suffix] + + [":" time-separator] + ["Z" time-suffix] + ) -## Based on this: https://stackoverflow.com/a/42936293/6823464 -(def: #export (to-text instant) +(def: #export (encode instant) (-> Instant Text) - (let [[[year month day] day-time] (extract-date instant) - day-time (if (order.>= duration.order duration.empty day-time) - day-time - (duration.merge duration.day day-time)) - [hours day-time] [(duration.query duration.hour day-time) (duration.frame duration.hour day-time)] - [minutes day-time] [(duration.query duration.minute day-time) (duration.frame duration.minute day-time)] - [seconds millis] [(duration.query duration.second day-time) (duration.frame duration.second day-time)]] - ($_ text@compose (i@encode year) "-" (pad (.nat month)) "-" (pad (.nat day)) "T" - (pad (.nat hours)) ":" (pad (.nat minutes)) ":" (pad (.nat seconds)) + (let [[date time] (..date-time instant) + time (if (:: duration.order < duration.empty time) + (duration.merge duration.day time) + time) + [hours time] [(duration.query duration.hour time) (duration.frame duration.hour time)] + [minutes time] [(duration.query duration.minute time) (duration.frame duration.minute time)] + [seconds millis] [(duration.query duration.second time) (duration.frame duration.second time)]] + ($_ text@compose + (:: date.codec encode date) + ..date-suffix (..pad (.nat hours)) + ..time-separator (..pad (.nat minutes)) + ..time-separator (..pad (.nat seconds)) (|> millis - (adjust-negative duration.second) + (..adjust-negative duration.second) duration.to-millis .nat - encode-millis) - "Z"))) - -## Codec::decode -(def: lex-year - (Parser Int) - (do p.monad - [sign (p.or (l.this "-") (l.this "+")) - raw-year (p.codec i.decimal (l.many l.decimal)) - #let [signum (case sign - (#.Left _) -1 - (#.Right _) +1)]] - (wrap (i.* signum raw-year)))) - -(def: lex-section - (Parser Int) - (p.codec i.decimal (l.exactly 2 l.decimal))) - -(def: lex-millis - (Parser Int) - (p.either (|> (l.at-most 3 l.decimal) - (p.codec i.decimal) - (p.after (l.this "."))) - (:: p.monad wrap +0))) - -(def: (leap-years year) - (-> Int Int) - (|> (i./ +4 year) - (i.- (i./ +100 year)) - (i.+ (i./ +400 year)))) - -## Based on: https://stackoverflow.com/a/3309340/6823464 -## (def: lex-instant -## (Parser Instant) -## (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) -## date.leap-year-months -## date.common-months) -## month-days (|> months -## (row.nth (.nat (dec utc-month))) -## maybe.assume)] -## _ (l.this "-") -## utc-day lex-section -## _ (p.assert "Invalid day." -## (and (i.>= +1 utc-day) -## (i.<= (.int month-days) utc-day))) -## _ (l.this "T") -## utc-hour lex-section -## _ (p.assert "Invalid hour." -## (and (i.>= +0 utc-hour) -## (i.<= +23 utc-hour))) -## _ (l.this ":") -## utc-minute lex-section -## _ (p.assert "Invalid minute." -## (and (i.>= +0 utc-minute) -## (i.<= +59 utc-minute))) -## _ (l.this ":") -## utc-second lex-section -## _ (p.assert "Invalid second." -## (and (i.>= +0 utc-second) -## (i.<= +59 utc-second))) -## utc-millis lex-millis -## _ (l.this "Z") -## #let [years-since-epoch (i.- epoch-year utc-year) -## previous-leap-days (i.- (leap-years epoch-year) -## (leap-years (dec utc-year))) -## year-days-so-far (|> (i.* +365 years-since-epoch) -## (i.+ previous-leap-days)) -## month-days-so-far (|> months -## row.to-list -## (list.take (.nat (dec utc-month))) -## (list@fold n.+ 0)) -## total-days (|> year-days-so-far -## (i.+ (.int month-days-so-far)) -## (i.+ (dec utc-day)))]] -## (wrap (|> epoch -## (shift (duration.scale-up total-days duration.day)) -## (shift (duration.scale-up utc-hour duration.hour)) -## (shift (duration.scale-up utc-minute duration.minute)) -## (shift (duration.scale-up utc-second duration.second)) -## (shift (duration.scale-up utc-millis duration.milli)))))) - -## (def: (decode input) -## (-> Text (Try Instant)) -## (l.run input lex-instant)) + ..encode-millis) + ..time-suffix))) + +(def: parse-section + (Parser Nat) + (<>.codec n.decimal (.exactly 2 .decimal))) + +(def: parse-millis + (Parser Nat) + (<>.either (|> (.at-most 3 .decimal) + (<>.codec n.decimal) + (<>.after (.this "."))) + (:: <>.monad wrap 0))) + +(template [ ] + [(exception: #export ( {value Nat}) + (exception.report + ["Value" (n@encode value)] + ["Minimum" (n@encode )] + ["Maximum" (n@encode )])) + + (def: + (Parser Nat) + (do <>.monad + [value ..parse-section] + (if (and (n.>= value) + (n.<= value)) + (wrap value) + (<>.lift (exception.throw [value])))))] + + [0 23 parse-hour invalid-hour] + [0 59 parse-minute invalid-minute] + [0 59 parse-second invalid-second] + ) -## (structure: #export _ -## {#.doc (doc "Based on ISO 8601." -## "For example: 2017-01-15T21:14:51.827Z")} -## (Codec Text Instant) -## (def: encode encode) -## (def: decode decode)) +(def: parser + (Parser Instant) + (do {@ <>.monad} + [days (:: @ map date.days date.parser) + _ (.this ..date-suffix) + utc-hour (<>.before (.this ..time-separator) + ..parse-hour) + utc-minute (<>.before (.this ..time-separator) + ..parse-minute) + utc-second ..parse-second + utc-millis (<>.before (.this ..time-suffix) + ..parse-millis)] + (wrap (|> (if (i.< +0 days) + (|> duration.day + (duration.scale-up (.nat (i.* -1 days))) + duration.inverse) + (duration.scale-up (.nat days) duration.day)) + (duration.merge (duration.scale-up utc-hour duration.hour)) + (duration.merge (duration.scale-up utc-minute duration.minute)) + (duration.merge (duration.scale-up utc-second duration.second)) + (duration.merge (duration.scale-up utc-millis duration.milli-second)) + ..absolute)))) + +(structure: #export codec + {#.doc (doc "Based on ISO 8601." + "For example: 2017-01-15T21:14:51.827Z")} + (Codec Text Instant) + + (def: encode ..encode) + (def: decode (.run ..parser))) (def: #export now (IO Instant) - (io (from-millis ("lux io current-time")))) + (io (..from-millis ("lux io current-time")))) (def: #export (date instant) (-> Instant Date) - (let [[[year month day] _] (extract-date instant)] - {#date.year year - #date.month (case (dec month) - +0 #month.January - +1 #month.February - +2 #month.March - +3 #month.April - +4 #month.May - +5 #month.June - +6 #month.July - +7 #month.August - +8 #month.September - +9 #month.October - +10 #month.November - +11 #month.December - _ (undefined)) - #date.day (.nat (dec day))})) - -(def: #export (month instant) - (-> Instant Month) - (let [[year month day] (date instant)] - month)) + (let [[date _] (..date-time instant)] + date)) -(def: #export (day instant) +(def: #export (day-of-week instant) (-> Instant Day) - (let [offset (relative instant) + (let [offset (..relative instant) days (duration.query duration.day offset) day-time (duration.frame duration.day offset) days (if (and (duration.negative? offset) diff --git a/stdlib/source/lux/time/month.lux b/stdlib/source/lux/time/month.lux index 585a3f98a..5baa8efa9 100644 --- a/stdlib/source/lux/time/month.lux +++ b/stdlib/source/lux/time/month.lux @@ -22,12 +22,14 @@ #November #December) -(structure: #export equivalence (Equivalence Month) +(structure: #export equivalence + (Equivalence Month) + (def: (= reference sample) (case [reference sample] (^template [] [ ] - #1) + true) ([#January] [#February] [#March] @@ -42,31 +44,37 @@ [#December]) _ - #0))) + false))) (def: #export (number month) (-> Month Nat) (case month - #January 00 - #February 01 - #March 02 - #April 03 - #May 04 - #June 05 - #July 06 - #August 07 - #September 08 - #October 09 - #November 10 - #December 11)) + #January 01 + #February 02 + #March 03 + #April 04 + #May 05 + #June 06 + #July 07 + #August 08 + #September 09 + #October 10 + #November 11 + #December 12)) -(structure: #export order (Order Month) +(structure: #export order + (Order Month) + (def: &equivalence ..equivalence) + (def: (< reference sample) - (n.< (number reference) (number sample)))) + (n.< (..number reference) (..number sample)))) -(structure: #export enum (Enum Month) +(structure: #export enum + (Enum Month) + (def: &order ..order) + (def: (succ month) (case month #January #February @@ -81,6 +89,7 @@ #October #November #November #December #December #January)) + (def: (pred month) (case month #February #January @@ -95,3 +104,45 @@ #November #October #December #November #January #December))) + +(def: #export (days month) + (-> Month Nat) + (case month + (^template [ ] + ) + ([31 #January] + [28 #February] + [31 #March] + + [30 #April] + [31 #May] + [30 #June] + + [31 #July] + [31 #August] + [30 #September] + + [31 #October] + [30 #November] + [31 #December]))) + +(def: #export (leap-year-days month) + (-> Month Nat) + (case month + #February (inc (..days month)) + _ (..days month))) + +(def: #export year + (List Month) + (list #January + #February + #March + #April + #May + #June + #July + #August + #September + #October + #November + #December)) diff --git a/stdlib/source/lux/time/year.lux b/stdlib/source/lux/time/year.lux new file mode 100644 index 000000000..9b6294a16 --- /dev/null +++ b/stdlib/source/lux/time/year.lux @@ -0,0 +1,67 @@ +(.module: + [lux #* + [data + [number + ["n" nat] + ["i" int]]]]) + +(type: #export Year + Int) + +(def: #export epoch + Year + +1970) + +(type: #export Period + Nat) + +(template [ ] + [(def: #export + Period + )] + + [004 leap] + [100 century] + [400 era] + ) + +(def: (divisible? factor input) + (-> Int Int Bit) + (|> input (i.% factor) (i.= +0))) + +## https://en.wikipedia.org/wiki/Leap_year#Algorithm +(def: #export (leap? year) + (-> Year Bit) + (and (..divisible? (.int ..leap) year) + (or (not (..divisible? (.int ..century) year)) + (..divisible? (.int ..era) year)))) + +(def: (with-year-0-leap year days) + (let [after-year-0? (i.> +0 year)] + (if after-year-0? + (i.+ +1 days) + days))) + +(def: #export (leaps year) + (-> Year Int) + (let [limit (if (i.> +0 year) + (dec year) + (inc year))] + (`` (|> +0 + (~~ (template [ ] + [( (i./ (.int ) limit))] + + [i.+ ..leap] + [i.- ..century] + [i.+ ..era] + )) + (..with-year-0-leap year))))) + +(def: days-per-normal-year + 365) + +(def: #export (days year) + (-> Year Int) + (|> year + (i.* (.int ..days-per-normal-year)) + (i.+ (..leaps year)))) diff --git a/stdlib/source/program/aedifex.lux b/stdlib/source/program/aedifex.lux index 874e32ceb..bfa2377f4 100644 --- a/stdlib/source/program/aedifex.lux +++ b/stdlib/source/program/aedifex.lux @@ -38,7 +38,8 @@ [command ["#." build] ["#." test] - ["#." auto]]]) + ["#." auto] + ["#." deploy]]]) (def: (read-file! path) (-> Path (IO (Try Binary))) @@ -133,12 +134,16 @@ #/cli.POM (..write-pom! project) + #/cli.Dependencies + (exec (..fetch-dependencies! project) + (wrap [])) + #/cli.Install (exec (..install! project) (wrap [])) - #/cli.Dependencies - (exec (..fetch-dependencies! project) + (#/cli.Deploy repository user password) + (exec (/deploy.do! repository user password project) (wrap [])) (#/cli.Compilation compilation) diff --git a/stdlib/source/program/aedifex/cli.lux b/stdlib/source/program/aedifex/cli.lux index 3cbb2aae8..b0d210c17 100644 --- a/stdlib/source/program/aedifex/cli.lux +++ b/stdlib/source/program/aedifex/cli.lux @@ -2,7 +2,9 @@ [lux #* [control ["<>" parser - ["." cli (#+ Parser)]]]]) + ["." cli (#+ Parser)]]]] + [// + [upload (#+ User Password)]]) (type: #export Compilation #Build @@ -15,8 +17,9 @@ (type: #export Command #POM - #Install #Dependencies + #Install + (#Deploy Text User Password) (#Compilation Compilation) (#Auto Compilation)) @@ -24,8 +27,13 @@ (Parser Command) ($_ <>.or (cli.this "pom") - (cli.this "install") (cli.this "deps") + (cli.this "install") + (<>.after (cli.this "deploy") + ($_ <>.and + cli.any + cli.any + cli.any)) ..compilation (<>.after (cli.this "auto") ..compilation) diff --git a/stdlib/source/program/aedifex/command/deploy.lux b/stdlib/source/program/aedifex/command/deploy.lux new file mode 100644 index 000000000..ed6667264 --- /dev/null +++ b/stdlib/source/program/aedifex/command/deploy.lux @@ -0,0 +1,67 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." exception (#+ exception:)] + [concurrency + ["." promise ("#@." monad)]]] + [data + [binary (#+ Binary)] + [text + ["%" format (#+ format)] + ["." encoding]] + [collection + ["." dictionary (#+ Dictionary)]] + [format + ["." binary] + ["." tar] + ["." xml]]] + [world + ["." file]]] + [program + [compositor + ["." export]]] + ["." /// #_ + ["/" project (#+ Project)] + ["//" upload (#+ User Password)] + ["#." action (#+ Action)] + ["#." command (#+ Command)] + ["#." dependency] + ["#." pom] + ["#." hash]]) + +(exception: #export (cannot-find-repository {repository Text} + {options (Dictionary Text ///dependency.Repository)}) + (exception.report + ["Repository" (%.text repository)] + ["Options" (exception.enumerate (function (_ [name repo]) + (format (%.text name) " := " (%.text repo))) + (dictionary.entries options))])) + +(def: #export (do! repository user password project) + (-> Text User Password (Command Any)) + (case (dictionary.get repository (get@ #/.deploy-repositories project)) + (#.Some repository) + (let [artifact (get@ #/.identity project) + deploy! (: (-> ///dependency.Type Binary (Action Any)) + (function (_ type content) + (promise.future + (//.upload repository + user + password + {#///dependency.artifact artifact + #///dependency.type type} + content))))] + (do {@ ///action.monad} + [library (:: @ map (binary.run tar.writer) + (export.library (file.async file.system) + (get@ #/.sources project))) + _ (deploy! ///dependency.pom (|> project ///pom.project (:: xml.codec encode) encoding.to-utf8)) + _ (deploy! ///dependency.lux-library library) + _ (deploy! "sha1" (///hash.sha1 library)) + _ (deploy! "md5" (///hash.md5 library))] + (wrap []))) + + #.None + (promise@wrap (exception.throw ..cannot-find-repository [repository (get@ #/.deploy-repositories project)])))) diff --git a/stdlib/source/program/aedifex/dependency.lux b/stdlib/source/program/aedifex/dependency.lux index 7c40bf2ae..92ac3e8ac 100644 --- a/stdlib/source/program/aedifex/dependency.lux +++ b/stdlib/source/program/aedifex/dependency.lux @@ -57,6 +57,7 @@ ["tar" lux-library] ["jar" jvm-library] + ["pom" pom] ) (import: #long java/lang/String) diff --git a/stdlib/source/program/aedifex/parser.lux b/stdlib/source/program/aedifex/parser.lux index bbcbabb95..17191d5cb 100644 --- a/stdlib/source/program/aedifex/parser.lux +++ b/stdlib/source/program/aedifex/parser.lux @@ -166,6 +166,11 @@ (Parser Module) .text) +(def: deploy-repository + (Parser [Text //dependency.Repository]) + (.tuple (<>.and .text + ..repository))) + (def: #export project (Parser /.Project) (do {@ <>.monad} @@ -187,4 +192,7 @@ (..singular input "target" .text)) (<>.maybe (..singular input "program" ..module)) (<>.maybe (..singular input "test" ..module)) + (<| (:: @ map (dictionary.from-list text.hash)) + (<>.default (list)) + (..plural input "deploy-repositories" ..deploy-repository)) ))) diff --git a/stdlib/source/program/aedifex/project.lux b/stdlib/source/program/aedifex/project.lux index ebd689760..20bbda840 100644 --- a/stdlib/source/program/aedifex/project.lux +++ b/stdlib/source/program/aedifex/project.lux @@ -1,7 +1,9 @@ (.module: [lux (#- Info Source Module) [data - ["." text]] + ["." text] + [collection + ["." dictionary (#+ Dictionary)]]] [world [net (#+ URL)] [file (#+ Path)]] @@ -64,4 +66,5 @@ #sources (List Source) #target Path #program (Maybe Module) - #test (Maybe Module)}) + #test (Maybe Module) + #deploy-repositories (Dictionary Text dependency.Repository)}) diff --git a/stdlib/source/program/aedifex/upload.lux b/stdlib/source/program/aedifex/upload.lux new file mode 100644 index 000000000..8b849ed10 --- /dev/null +++ b/stdlib/source/program/aedifex/upload.lux @@ -0,0 +1,100 @@ +(.module: + [lux #* + ["." host (#+ import:)] + [abstract + [monad (#+ Monad do)]] + [control + ["." io (#+ IO)] + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." binary (#+ Binary)] + ["." text + ["%" format (#+ format)] + ["." encoding]]] + [time + ["." instant]] + [world + [net (#+ URL) + ["." uri]]]] + ["." // #_ + ["#." dependency (#+ Repository Dependency)] + ["#." artifact]]) + +(type: #export (Action a) + (IO (Try a))) + +(def: #export monad + (:coerce (Monad Action) + (try.with io.monad))) + +(type: #export User + Text) + +(type: #export Password + Text) + +(def: (url repository dependency) + (-> Repository Dependency URL) + (format repository + uri.separator + (//artifact.path (get@ #//dependency.artifact dependency)) + "." + (get@ #//dependency.type dependency))) + +(import: #long java/lang/AutoCloseable + (close [] #io #try void)) + +(import: #long java/io/OutputStream + (flush [] #io #try void) + (write [[byte]] #io #try void)) + +(import: #long java/lang/String) + +(import: #long java/net/URLConnection + (setDoOutput [boolean] #io #try void) + (setRequestProperty [java/lang/String java/lang/String] #io #try void) + (getOutputStream [] #io #try java/io/OutputStream)) + +(import: #long java/net/HttpURLConnection + (setRequestMethod [java/lang/String] #io #try void) + (getResponseCode [] #io #try int)) + +(import: #long java/net/URL + (new [java/lang/String]) + (openConnection [] #io #try java/net/URLConnection)) + +(import: #long java/util/Base64$Encoder + (encodeToString [[byte]] java/lang/String)) + +(import: #long java/util/Base64 + (#static getEncoder [] java/util/Base64$Encoder)) + +(exception: #export (failure {code Int}) + (exception.report + ["Code" (%.int code)])) + +(def: (basic-auth user password) + (-> User Password Text) + (format "Basic " (java/util/Base64$Encoder::encodeToString (encoding.to-utf8 (format user ":" password)) + (java/util/Base64::getEncoder)))) + +(def: #export (upload repository user password dependency content) + (-> Repository User Password Dependency Binary + (Action Any)) + (do {@ ..monad} + [connection (|> (..url repository dependency) + java/net/URL::new + java/net/URL::openConnection) + #let [connection (:coerce java/net/HttpURLConnection connection)] + _ (java/net/HttpURLConnection::setRequestMethod "PUT" connection) + _ (java/net/URLConnection::setDoOutput true connection) + _ (java/net/URLConnection::setRequestProperty "Authorization" (..basic-auth user password) connection) + stream (java/net/URLConnection::getOutputStream connection) + _ (java/io/OutputStream::write content stream) + _ (java/io/OutputStream::flush stream) + _ (java/lang/AutoCloseable::close stream) + code (java/net/HttpURLConnection::getResponseCode connection)] + (case code + +200 (wrap []) + _ (:: io.monad wrap (exception.throw ..failure [code]))))) diff --git a/stdlib/source/test/lux/macro/poly/json.lux b/stdlib/source/test/lux/macro/poly/json.lux index 55b2d2dd2..144994f50 100644 --- a/stdlib/source/test/lux/macro/poly/json.lux +++ b/stdlib/source/test/lux/macro/poly/json.lux @@ -13,6 +13,7 @@ ["$." codec]]}] [control pipe + ["." try] ["p" parser ## TODO: Get rid of this import ASAP [json (#+)]]] diff --git a/stdlib/source/test/lux/time/date.lux b/stdlib/source/test/lux/time/date.lux index 6ca543cf9..fd17f3075 100644 --- a/stdlib/source/test/lux/time/date.lux +++ b/stdlib/source/test/lux/time/date.lux @@ -1,15 +1,18 @@ (.module: [lux #* ["%" data/text/format (#+ format)] - ["r" math/random (#+ Random)] ["_" test (#+ Test)] + [math + ["." random (#+ Random)]] [abstract ["." monad (#+ do)] {[0 #spec] [/ ["$." equivalence] ["$." order] - ["$." codec]]}]] + ["$." codec]]}] + [control + ["." try]]] [// ["_." instant]] {1 @@ -19,7 +22,8 @@ (def: #export date (Random Date) - (|> _instant.instant (:: r.monad map //instant.date))) + (:: random.monad map //instant.date + _instant.instant)) (def: #export test Test diff --git a/stdlib/source/test/lux/time/duration.lux b/stdlib/source/test/lux/time/duration.lux index a08019366..5900f1958 100644 --- a/stdlib/source/test/lux/time/duration.lux +++ b/stdlib/source/test/lux/time/duration.lux @@ -15,13 +15,13 @@ ["n" nat] ["i" int]]] [math - ["r" random (#+ Random)]]] + ["." random (#+ Random)]]] {1 ["." / (#+ Duration)]}) (def: #export duration (Random Duration) - (|> r.int (:: r.monad map /.from-millis))) + (:: random.monad map /.from-millis random.int)) (def: #export test Test @@ -30,17 +30,16 @@ ($equivalence.spec /.equivalence ..duration) ($order.spec /.order ..duration) ($monoid.spec /.equivalence /.monoid ..duration) - ## TODO; Uncomment ASAP - ## ($codec.spec /.equivalence /.codec ..duration) + ($codec.spec /.equivalence /.codec ..duration) - (do r.monad - [millis r.int] + (do random.monad + [millis random.int] (_.test "Can convert from/to milliseconds." (|> millis /.from-millis /.to-millis (i.= millis)))) - (do {@ r.monad} + (do {@ random.monad} [sample (|> duration (:: @ map (/.frame /.day))) frame duration - factor (|> r.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + factor (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) #let [(^open "/@.") /.order]] ($_ _.and (_.test "Can scale a duration." diff --git a/stdlib/source/test/lux/time/instant.lux b/stdlib/source/test/lux/time/instant.lux index f2e44cead..3849c7b67 100644 --- a/stdlib/source/test/lux/time/instant.lux +++ b/stdlib/source/test/lux/time/instant.lux @@ -11,13 +11,13 @@ ["$." enum] ["$." codec]]}] [control - pipe] + ["." try]] [data ["." text] [number ["i" int]]] [math - ["r" random (#+ Random)]] + ["." random (#+ Random)]] [time ["@d" duration] ["@date" date]]] @@ -26,11 +26,9 @@ {1 ["." / (#+ Instant)]}) -(def: boundary Int +99,999,999,999,999) - (def: #export instant (Random Instant) - (:: r.monad map (|>> (i.% boundary) /.from-millis) r.int)) + (:: random.monad map /.from-millis random.int)) (def: #export test Test @@ -39,14 +37,13 @@ ($equivalence.spec /.equivalence ..instant) ($order.spec /.order ..instant) ($enum.spec /.enum ..instant) - ## TODO; Uncomment ASAP - ## ($codec.spec /.equivalence /.codec ..instant) + ($codec.spec /.equivalence /.codec ..instant) - (do r.monad - [millis r.int] + (do random.monad + [millis random.int] (_.test "Can convert from/to milliseconds." (|> millis /.from-millis /.to-millis (i.= millis)))) - (do r.monad + (do random.monad [sample instant span _duration.duration #let [(^open "@/.") /.equivalence -- cgit v1.2.3