aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/data/text.lux2
-rw-r--r--stdlib/source/lux/data/text/format.lux22
-rw-r--r--stdlib/source/lux/time/date.lux460
-rw-r--r--stdlib/source/lux/time/day.lux15
-rw-r--r--stdlib/source/lux/time/duration.lux108
-rw-r--r--stdlib/source/lux/time/instant.lux349
-rw-r--r--stdlib/source/lux/time/month.lux87
-rw-r--r--stdlib/source/lux/time/year.lux67
-rw-r--r--stdlib/source/program/aedifex.lux11
-rw-r--r--stdlib/source/program/aedifex/cli.lux14
-rw-r--r--stdlib/source/program/aedifex/command/deploy.lux67
-rw-r--r--stdlib/source/program/aedifex/dependency.lux1
-rw-r--r--stdlib/source/program/aedifex/parser.lux8
-rw-r--r--stdlib/source/program/aedifex/project.lux7
-rw-r--r--stdlib/source/program/aedifex/upload.lux100
-rw-r--r--stdlib/source/test/lux/macro/poly/json.lux1
-rw-r--r--stdlib/source/test/lux/time/date.lux10
-rw-r--r--stdlib/source/test/lux/time/duration.lux15
-rw-r--r--stdlib/source/test/lux/time/instant.lux17
19 files changed, 913 insertions, 448 deletions
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 [<name> <type> <formatter>]
[(def: #export <name>
(Format <type>)
@@ -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
+ ["<t>" 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 [<name> <type> <field> <post-processing>]
+ [(def: #export <name>
+ (-> Date <type>)
+ (|>> :representation (get@ <field>) <post-processing>))]
+
+ [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 (<t>.this "-") (wrap []))
+ digits (<t>.many <t>.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 (<t>.exactly 2 <t>.decimal)))
+
+(def: parse-millis
+ (Parser Nat)
+ (<>.either (|> (<t>.at-most 3 <t>.decimal)
+ (<>.codec n.decimal)
+ (<>.after (<t>.this ".")))
+ (:: <>.monad wrap 0)))
+
+(template [<minimum> <maximum> <parser> <exception>]
+ [(exception: #export (<exception> {value Nat})
+ (exception.report
+ ["Value" (n@encode value)]
+ ["Minimum" (n@encode <minimum>)]
+ ["Maximum" (n@encode <maximum>)]))
+
+ (def: <parser>
+ (Parser Nat)
+ (do <>.monad
+ [value ..parse-section]
+ (if (and (n.>= <minimum> value)
+ (n.<= <maximum> value))
+ (wrap value)
+ (<>.lift (exception.throw <exception> [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
+ _ (<t>.this ..separator)
+ utc-month ..parse-month
+ _ (<t>.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 (<t>.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 [<pull> +3
+ <push> +9]
+ (def: (internal-month civil-month)
+ (-> Nat Int)
+ (if (n.< ..first-month-of-civil-year civil-month)
+ (i.+ <push> (.int civil-month))
+ (i.- <pull> (.int civil-month))))
+
+ (def: (civil-month internal-month)
+ (-> Int Nat)
+ (.nat (if (i.< +10 internal-month)
+ (i.+ <pull> internal-month)
+ (i.- <push> internal-month)))))
+
+(with-expansions [<up> +153
+ <translation> +2
+ <down> +5]
+ (def: day-of-year-from-month
+ (-> Nat Int)
+ (|>> ..internal-month
+ (i.* <up>)
+ (i.+ <translation>)
+ (i./ <down>)))
+
+ (def: month-from-day-of-year
+ (-> Int Nat)
+ (|>> (i.* <down>)
+ (i.+ <translation>)
+ (i./ <up>)
+ ..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 [<tag>]
@@ -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
+ ["<t>" text (#+ Parser)]]]
[data
[number
["." nat ("#@." decimal)]
@@ -31,22 +31,22 @@
(-> Duration Int)
(|>> :representation))
- (template [<name> <op>]
+ (template [<op> <name>]
[(def: #export (<name> param subject)
(-> Duration Duration Duration)
(:abstraction (<op> (:representation param) (:representation subject))))]
- [merge i.+]
- [frame i.%]
+ [i.+ merge]
+ [i.% frame]
)
- (template [<name> <op>]
+ (template [<op> <name>]
[(def: #export (<name> scalar)
(-> Nat Duration Duration)
(|>> :representation (<op> (.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 [<name> <op>]
+ (template [<op> <name>]
[(def: #export <name>
(-> Duration Bit)
(|>> :representation (<op> +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 [<name> <scale> <base>]
- [(def: #export <name> (scale-up <scale> <base>))]
+ [(def: #export <name>
+ (..scale-up <scale> <base>))]
[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 [<value> <definition>]
+ [(def: <definition> <value>)]
+
+ ["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)
+ (|> (<t>.many <t>.decimal) (<>.codec nat.decimal) (<>.before (<t>.this suffix)) (<>.default 0))))]
+ (do <>.monad
+ [sign (<>.or (<t>.this ..negative-sign)
+ (<t>.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 (<t>.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
+ ["<t>" 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 [<value> <definition>]
+ [(def: <definition> Text <value>)]
+
+ ["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 (<t>.exactly 2 <t>.decimal)))
+
+(def: parse-millis
+ (Parser Nat)
+ (<>.either (|> (<t>.at-most 3 <t>.decimal)
+ (<>.codec n.decimal)
+ (<>.after (<t>.this ".")))
+ (:: <>.monad wrap 0)))
+
+(template [<minimum> <maximum> <parser> <exception>]
+ [(exception: #export (<exception> {value Nat})
+ (exception.report
+ ["Value" (n@encode value)]
+ ["Minimum" (n@encode <minimum>)]
+ ["Maximum" (n@encode <maximum>)]))
+
+ (def: <parser>
+ (Parser Nat)
+ (do <>.monad
+ [value ..parse-section]
+ (if (and (n.>= <minimum> value)
+ (n.<= <maximum> value))
+ (wrap value)
+ (<>.lift (exception.throw <exception> [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)
+ _ (<t>.this ..date-suffix)
+ utc-hour (<>.before (<t>.this ..time-separator)
+ ..parse-hour)
+ utc-minute (<>.before (<t>.this ..time-separator)
+ ..parse-minute)
+ utc-second ..parse-second
+ utc-millis (<>.before (<t>.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 (<t>.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 [<tag>]
[<tag> <tag>]
- #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 [<days> <month>]
+ <month> <days>)
+ ([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 [<period> <name>]
+ [(def: #export <name>
+ Period
+ <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 [<polarity> <years>]
+ [(<polarity> (i./ (.int <years>) 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)
<c>.text)
+(def: deploy-repository
+ (Parser [Text //dependency.Repository])
+ (<c>.tuple (<>.and <c>.text
+ ..repository)))
+
(def: #export project
(Parser /.Project)
(do {@ <>.monad}
@@ -187,4 +192,7 @@
(..singular input "target" <c>.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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 13:56:29 +0000