From 2d16bdfa2854d851034eff9f042863dcceb8664a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 3 Oct 2020 20:13:27 -0400 Subject: Gave Aedifex support for multiple profiles. --- stdlib/source/lux/data/binary.lux | 13 +- stdlib/source/lux/data/text/unicode.lux | 68 ++++---- stdlib/source/lux/time.lux | 190 +++++++++++++++++++++++ stdlib/source/lux/time/date.lux | 15 +- stdlib/source/lux/time/instant.lux | 112 +++---------- stdlib/source/lux/time/year.lux | 12 +- stdlib/source/program/aedifex.lux | 107 +++++++------ stdlib/source/program/aedifex/cli.lux | 25 ++- stdlib/source/program/aedifex/command.lux | 4 +- stdlib/source/program/aedifex/command/auto.lux | 14 +- stdlib/source/program/aedifex/command/build.lux | 33 ++-- stdlib/source/program/aedifex/command/deploy.lux | 33 ++-- stdlib/source/program/aedifex/local.lux | 33 ++-- stdlib/source/program/aedifex/parser.lux | 106 +++++++++---- stdlib/source/program/aedifex/pom.lux | 31 ++-- stdlib/source/program/aedifex/profile.lux | 135 ++++++++++++++++ stdlib/source/program/aedifex/project.lux | 113 ++++++-------- stdlib/source/test/lux/control/parser/text.lux | 6 +- stdlib/source/test/lux/data/binary.lux | 161 +++++++++++++------ 19 files changed, 802 insertions(+), 409 deletions(-) create mode 100644 stdlib/source/lux/time.lux create mode 100644 stdlib/source/program/aedifex/profile.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/data/binary.lux b/stdlib/source/lux/data/binary.lux index ed0d992e9..6bb5667bf 100644 --- a/stdlib/source/lux/data/binary.lux +++ b/stdlib/source/lux/data/binary.lux @@ -300,9 +300,16 @@ (exception.throw ..slice-out-of-bounds [size from to])) (exception.throw ..inverted-slice [size from to])))) -(def: #export (slice' from binary) - (-> Nat Binary (Try Binary)) - (slice from (dec (..!size binary)) binary)) +(def: #export (drop from binary) + (-> Nat Binary Binary) + (case from + 0 binary + _ (case (..slice from (dec (..!size binary)) binary) + (#try.Success slice) + slice + + (#try.Failure _) + (..create 0)))) (structure: #export monoid (Monoid Binary) diff --git a/stdlib/source/lux/data/text/unicode.lux b/stdlib/source/lux/data/text/unicode.lux index 8faf56789..234309ddf 100644 --- a/stdlib/source/lux/data/text/unicode.lux +++ b/stdlib/source/lux/data/text/unicode.lux @@ -165,23 +165,23 @@ [arabic-presentation-forms-b "FE70" "FEFF"] [halfwidth-and-fullwidth-forms "FF00" "FFEF"] [specials "FFF0" "FFFF"] - [linear-b-syllabary "10000" "1007F"] - [linear-b-ideograms "10080" "100FF"] - [aegean-numbers "10100" "1013F"] - [old-italic "10300" "1032F"] - [gothic "10330" "1034F"] - [ugaritic "10380" "1039F"] - [deseret "10400" "1044F"] - [shavian "10450" "1047F"] - [osmanya "10480" "104AF"] - [cypriot-syllabary "10800" "1083F"] - [byzantine-musical-symbols "1D000" "1D0FF"] - [musical-symbols "1D100" "1D1FF"] - [tai-xuan-jing-symbols "1D300" "1D35F"] - [mathematical-alphanumeric-symbols "1D400" "1D7FF"] - [cjk-unified-ideographs-extension-b "20000" "2A6DF"] - [cjk-compatibility-ideographs-supplement "2F800" "2FA1F"] - [tags "E0000" "E007F"] + ## [linear-b-syllabary "10000" "1007F"] + ## [linear-b-ideograms "10080" "100FF"] + ## [aegean-numbers "10100" "1013F"] + ## [old-italic "10300" "1032F"] + ## [gothic "10330" "1034F"] + ## [ugaritic "10380" "1039F"] + ## [deseret "10400" "1044F"] + ## [shavian "10450" "1047F"] + ## [osmanya "10480" "104AF"] + ## [cypriot-syllabary "10800" "1083F"] + ## [byzantine-musical-symbols "1D000" "1D0FF"] + ## [musical-symbols "1D100" "1D1FF"] + ## [tai-xuan-jing-symbols "1D300" "1D35F"] + ## [mathematical-alphanumeric-symbols "1D400" "1D7FF"] + ## [cjk-unified-ideographs-extension-b "20000" "2A6DF"] + ## [cjk-compatibility-ideographs-supplement "2F800" "2FA1F"] + ## [tags "E0000" "E007F"] ## Specialized segments [basic-latin/decimal "0030" "0039"] @@ -317,23 +317,23 @@ arabic-presentation-forms-b halfwidth-and-fullwidth-forms specials - linear-b-syllabary - linear-b-ideograms - aegean-numbers - old-italic - gothic - ugaritic - deseret - shavian - osmanya - cypriot-syllabary - byzantine-musical-symbols - musical-symbols - tai-xuan-jing-symbols - mathematical-alphanumeric-symbols - cjk-unified-ideographs-extension-b - cjk-compatibility-ideographs-supplement - tags + ## linear-b-syllabary + ## linear-b-ideograms + ## aegean-numbers + ## old-italic + ## gothic + ## ugaritic + ## deseret + ## shavian + ## osmanya + ## cypriot-syllabary + ## byzantine-musical-symbols + ## musical-symbols + ## tai-xuan-jing-symbols + ## mathematical-alphanumeric-symbols + ## cjk-unified-ideographs-extension-b + ## cjk-compatibility-ideographs-supplement + ## tags )])) (def: #export full diff --git a/stdlib/source/lux/time.lux b/stdlib/source/lux/time.lux new file mode 100644 index 000000000..ecfb1edb1 --- /dev/null +++ b/stdlib/source/lux/time.lux @@ -0,0 +1,190 @@ +(.module: + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [enum (#+ Enum)] + [codec (#+ Codec)] + [monad (#+ Monad do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + ["" text (#+ Parser)]]] + [data + ["." text ("#@." monoid)] + [number + ["n" nat ("#@." decimal)]]] + [type + abstract]] + [/ + ["." duration (#+ Duration)]]) + +(template [ ] + [(def: #export + Nat + (.nat (duration.query )))] + + [milli-seconds duration.milli-second duration.second] + [seconds duration.second duration.minute] + [minutes duration.minute duration.hour] + [hours duration.hour duration.day] + ) + +(def: limit + Nat + (.nat (duration.to-millis duration.day))) + +(exception: #export (time-exceeds-a-day {time Nat}) + (exception.report + ["Time (in milli-seconds)" (n@encode time)] + ["Maximum (in milli-seconds)" (n@encode (dec limit))])) + +(def: separator ":") + +(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 0)] + ["Maximum" (n@encode (dec ))])) + + (def: + (Parser Nat) + (do <>.monad + [value ] + (if (and (n.>= 0 value) + (n.< value)) + (wrap value) + (<>.lift (exception.throw [value])))))] + + [..hours parse-hour invalid-hour ..parse-section] + [..minutes parse-minute invalid-minute ..parse-section] + [..seconds parse-second invalid-second ..parse-section] + [..milli-seconds parse-millis invalid-milli-second ..parse-millis'] + ) + +(abstract: #export Time + Nat + + {#.doc "Time is defined as milliseconds since the start of the day (00:00:00.000)."} + + (def: #export start + {#.doc "The instant corresponding to the start of the day: 00:00:00.000"} + Time + (:abstraction 0)) + + (def: #export (from-millis milli-seconds) + (-> Nat (Try Time)) + (if (n.< ..limit milli-seconds) + (#try.Success (:abstraction milli-seconds)) + (exception.throw ..time-exceeds-a-day [milli-seconds]))) + + (def: #export to-millis + (-> Time Nat) + (|>> :representation)) + + (structure: #export equivalence + (Equivalence Time) + + (def: (= param subject) + (n.= (:representation param) (:representation subject)))) + + (structure: #export order + (Order Time) + + (def: &equivalence ..equivalence) + + (def: (< param subject) + (n.< (:representation param) (:representation subject)))) + + (`` (structure: #export enum + (Enum Time) + + (def: &order ..order) + + (def: succ + (|>> :representation (n.% ..limit) :abstraction)) + + (def: (pred time) + (:abstraction (dec (case (:representation time) + 0 ..limit + millis millis)))))) + + (def: #export parser + (Parser Time) + (let [to-millis (: (-> Duration Nat) + (|>> duration.to-millis .nat)) + hour (to-millis duration.hour) + minute (to-millis duration.minute) + second (to-millis duration.second) + millis (to-millis duration.milli-second)] + (do {@ <>.monad} + [utc-hour ..parse-hour + _ (.this ..separator) + utc-minute ..parse-minute + _ (.this ..separator) + utc-second ..parse-second + utc-millis ..parse-millis] + (wrap (:abstraction + ($_ n.+ + (n.* utc-hour hour) + (n.* utc-minute minute) + (n.* utc-second second) + (n.* utc-millis millis))))))) + ) + +(def: (pad value) + (-> Nat Text) + (if (n.< 10 value) + (text@compose "0" (n@encode value)) + (n@encode value))) + +(def: (adjust-negative space duration) + (-> Duration Duration Duration) + (if (duration.negative? duration) + (duration.merge space duration) + duration)) + +(def: (encode-millis millis) + (-> Nat Text) + (cond (n.= 0 millis) "" + (n.< 10 millis) ($_ text@compose ".00" (n@encode millis)) + (n.< 100 millis) ($_ text@compose ".0" (n@encode millis)) + ## (n.< 1,000 millis) + ($_ text@compose "." (n@encode millis)))) + +(def: (encode time) + (-> Time Text) + (let [time (|> time ..to-millis .int duration.from-millis) + [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 + (..pad (.nat hours)) + ..separator (..pad (.nat minutes)) + ..separator (..pad (.nat seconds)) + (|> millis + (..adjust-negative duration.second) + duration.to-millis + .nat + ..encode-millis)))) + +(structure: #export codec + {#.doc (doc "Based on ISO 8601." + "For example: 21:14:51.827")} + (Codec Text Time) + + (def: encode ..encode) + (def: decode (.run ..parser))) diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux index 01b521ca6..455176de6 100644 --- a/stdlib/source/lux/time/date.lux +++ b/stdlib/source/lux/time/date.lux @@ -211,11 +211,8 @@ (def: encode ..encode) (def: decode (.run ..parser))) -(def: days-per-year - 365) - (def: days-per-leap - (|> ..days-per-year + (|> //year.days (n.* 4) (n.+ 1))) @@ -223,7 +220,7 @@ (let [leaps-per-century (n./ //year.leap //year.century)] (|> //year.century - (n.* ..days-per-year) + (n.* //year.days) (n.+ leaps-per-century) (n.- 1)))) @@ -239,7 +236,7 @@ leaps::70 (n./ //year.leap years::70) days::70 (|> years::70 - (n.* ..days-per-year) + (n.* //year.days) (n.+ leaps::70)) ## The epoch is being calculated from March 1st, instead of January 1st. january-&-february (n.+ (//month.days #//month.January) @@ -317,7 +314,7 @@ ..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.days) 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) @@ -337,11 +334,11 @@ (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))) + (i./ (.int //year.days))) 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.days) 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) diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux index fd842aff6..5f044fa71 100644 --- a/stdlib/source/lux/time/instant.lux +++ b/stdlib/source/lux/time/instant.lux @@ -8,6 +8,7 @@ [monad (#+ Monad do)]] [control [io (#+ IO io)] + ["." try] ["." exception (#+ exception:)] ["<>" parser ["" text (#+ Parser)]]] @@ -22,7 +23,7 @@ ["." list ("#@." fold)]]] [type abstract]] - [// + ["." // (#+ Time) ["." duration (#+ Duration)] ["." year (#+ Year)] ["." month (#+ Month)] @@ -88,26 +89,6 @@ Instant (..from-millis +0)) -(def: (pad value) - (-> Nat Text) - (if (n.< 10 value) - (text@compose "0" (n@encode value)) - (n@encode value))) - -(def: (adjust-negative space duration) - (-> Duration Duration Duration) - (if (duration.negative? duration) - (duration.merge space duration) - duration)) - -(def: (encode-millis millis) - (-> Nat Text) - (cond (n.= 0 millis) "" - (n.< 10 millis) ($_ text@compose ".00" (n@encode millis)) - (n.< 100 millis) ($_ text@compose ".0" (n@encode millis)) - ## (n.< 1,000 millis) - ($_ text@compose "." (n@encode millis)))) - (def: millis-per-day (duration.query duration.milli-second duration.day)) @@ -128,85 +109,37 @@ [(def: Text )] ["T" date-suffix] - - [":" time-separator] ["Z" time-suffix] ) -(def: #export (encode instant) +(def: (clock-time duration) + (-> Duration Time) + (let [time (if (:: duration.order < duration.empty duration) + (duration.merge duration.day duration) + duration)] + (|> time duration.to-millis .nat //.from-millis try.assume))) + +(def: (encode instant) (-> Instant Text) (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)]] + time (..clock-time 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) - duration.to-millis - .nat - ..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] - ) + (:: date.codec encode date) ..date-suffix + (:: //.codec encode time) ..time-suffix))) (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)] + time (:: @ map //.to-millis //.parser) + _ (.this ..time-suffix)] (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)) + (duration.merge (duration.scale-up time duration.milli-second)) ..absolute)))) (structure: #export codec @@ -221,10 +154,15 @@ (IO Instant) (io (..from-millis ("lux io current-time")))) -(def: #export (date instant) - (-> Instant Date) - (let [[date _] (..date-time instant)] - date)) +(template [ ] + [(def: #export ( instant) + (-> Instant ) + (let [[date time] (..date-time instant)] + (|> )))] + + [date Date (|>)] + [time Time ..clock-time] + ) (def: #export (day-of-week instant) (-> Instant Day) diff --git a/stdlib/source/lux/time/year.lux b/stdlib/source/lux/time/year.lux index 9b6294a16..0ba2025c6 100644 --- a/stdlib/source/lux/time/year.lux +++ b/stdlib/source/lux/time/year.lux @@ -8,6 +8,9 @@ (type: #export Year Int) +(def: #export days + 365) + (def: #export epoch Year +1970) @@ -56,12 +59,3 @@ [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 bfa2377f4..e29af6e7a 100644 --- a/stdlib/source/program/aedifex.lux +++ b/stdlib/source/program/aedifex.lux @@ -19,7 +19,9 @@ ["%" format (#+ format)] ["." encoding]] [format - ["." xml]]] + ["." xml]] + [collection + ["." set]]] [tool [compiler [language @@ -29,7 +31,8 @@ ["." file (#+ Path)]]] ["." / #_ [action (#+ Action)] - ["#" project] + ["#" profile] + ["#." project (#+ Project)] ["#." parser] ["#." pom] ["#." cli] @@ -61,20 +64,20 @@ (#.Right [end lux-code]) (#try.Success lux-code)))) -(def: (write-pom!' path project) - (-> Path /.Project (IO (Try Any))) +(def: (write-pom!' path profile) + (-> Path /.Profile (IO (Try Any))) (do (try.with io.monad) - [file (!.use (:: file.system file) [path])] - (|> project - /pom.project + [file (!.use (:: file.system file) [path]) + pom (:: io.monad wrap (/pom.project profile))] + (|> pom (:: xml.codec encode) encoding.to-utf8 (!.use (:: file over-write))))) -(def: (write-pom! project) - (-> /.Project (IO Any)) +(def: (write-pom! profile) + (-> /.Profile (IO Any)) (do io.monad - [outcome (write-pom!' /pom.file project)] + [outcome (write-pom!' /pom.file profile)] (case outcome (#try.Success value) (wrap (log! "Successfully wrote POM file!")) @@ -83,10 +86,10 @@ (wrap (log! (format "Could not write POM file:" text.new-line error)))))) -(def: (install! project) - (-> /.Project (Promise Any)) +(def: (install! profile) + (-> /.Profile (Promise Any)) (do promise.monad - [outcome (/local.install (file.async file.system) project)] + [outcome (/local.install (file.async file.system) profile)] (wrap (case outcome (#try.Success _) (log! "Successfully installed locally!") @@ -95,16 +98,16 @@ (log! (format "Could not install locally:" text.new-line error)))))) -(def: (fetch-dependencies! project) - (-> /.Project (Promise Any)) +(def: (fetch-dependencies! profile) + (-> /.Profile (Promise Any)) (do promise.monad [outcome (do (try.with promise.monad) [cache (/local.all-cached (file.async file.system) - (get@ #/.dependencies project) + (set.to-list (get@ #/.dependencies profile)) /dependency.empty) resolution (promise.future - (/dependency.resolve-all (get@ #/.repositories project) - (get@ #/.dependencies project) + (/dependency.resolve-all (set.to-list (get@ #/.repositories profile)) + (set.to-list (get@ #/.dependencies profile)) cache))] (/local.cache-all (file.async file.system) resolution))] @@ -117,52 +120,48 @@ error)))))) (def: project - (-> Binary (Try /.Project)) + (-> Binary (Try Project)) (|>> (do> try.monad [encoding.from-utf8] [..read-code] [(list) (.run /parser.project)]))) -(program: [{command /cli.command}] +(program: [{[profile operation] /cli.command}] (do {@ io.monad} [data (..read-file! /.file)] - (case data - (#try.Success data) - (case (..project data) - (#try.Success project) - (case command - #/cli.POM - (..write-pom! project) - - #/cli.Dependencies - (exec (..fetch-dependencies! project) - (wrap [])) + (case (do try.monad + [data data + project (..project data)] + (/project.profile project profile)) + (#try.Success profile) + (case operation + #/cli.POM + (..write-pom! profile) + + #/cli.Dependencies + (exec (..fetch-dependencies! profile) + (wrap [])) - #/cli.Install - (exec (..install! project) - (wrap [])) + #/cli.Install + (exec (..install! profile) + (wrap [])) - (#/cli.Deploy repository user password) - (exec (/deploy.do! repository user password project) - (wrap [])) + (#/cli.Deploy repository user password) + (exec (/deploy.do! repository user password profile) + (wrap [])) - (#/cli.Compilation compilation) - (case compilation - #/cli.Build (exec (/build.do! project) - (wrap [])) - #/cli.Test (exec (/test.do! project) - (wrap []))) + (#/cli.Compilation compilation) + (case compilation + #/cli.Build (exec (/build.do! profile) + (wrap [])) + #/cli.Test (exec (/test.do! profile) + (wrap []))) - (#/cli.Auto auto) - (exec (case auto - #/cli.Build (/auto.do! /build.do! project) - #/cli.Test (/auto.do! /test.do! project)) - (wrap []))) - - (#try.Failure error) - (wrap (log! (format "Invalid format file:" text.new-line - error)))) + (#/cli.Auto auto) + (exec (case auto + #/cli.Build (/auto.do! /build.do! profile) + #/cli.Test (/auto.do! /test.do! profile)) + (wrap []))) (#try.Failure error) - (wrap (log! (format "Could not read file: " - (%.text /.file))))))) + (wrap (log! error))))) diff --git a/stdlib/source/program/aedifex/cli.lux b/stdlib/source/program/aedifex/cli.lux index b0d210c17..dc64dee6e 100644 --- a/stdlib/source/program/aedifex/cli.lux +++ b/stdlib/source/program/aedifex/cli.lux @@ -1,10 +1,11 @@ (.module: - [lux #* + [lux (#- Name) [control ["<>" parser ["." cli (#+ Parser)]]]] [// - [upload (#+ User Password)]]) + [upload (#+ User Password)] + ["/" profile (#+ Name)]]) (type: #export Compilation #Build @@ -15,7 +16,7 @@ (<>.or (cli.this "build") (cli.this "test"))) -(type: #export Command +(type: #export Operation #POM #Dependencies #Install @@ -23,8 +24,11 @@ (#Compilation Compilation) (#Auto Compilation)) -(def: #export command - (Parser Command) +(type: #export Command + [Name Operation]) + +(def: operation + (Parser Operation) ($_ <>.or (cli.this "pom") (cli.this "deps") @@ -38,3 +42,14 @@ (<>.after (cli.this "auto") ..compilation) )) + +(def: #export command + (Parser Command) + ($_ <>.either + (<>.after (cli.this "with") + ($_ <>.and + cli.any + ..operation)) + (:: <>.monad map (|>> [/.default]) + ..operation) + )) diff --git a/stdlib/source/program/aedifex/command.lux b/stdlib/source/program/aedifex/command.lux index 8b4432a97..5248b0273 100644 --- a/stdlib/source/program/aedifex/command.lux +++ b/stdlib/source/program/aedifex/command.lux @@ -1,8 +1,8 @@ (.module: [lux #*] ["." // #_ - ["#" project] + ["#" profile] ["#." action (#+ Action)]]) (type: #export (Command a) - (-> //.Project (Action a))) + (-> //.Profile (Action a))) diff --git a/stdlib/source/program/aedifex/command/auto.lux b/stdlib/source/program/aedifex/command/auto.lux index 5bf759a06..cbb76edbb 100644 --- a/stdlib/source/program/aedifex/command/auto.lux +++ b/stdlib/source/program/aedifex/command/auto.lux @@ -11,12 +11,13 @@ [data [collection ["." array] - ["." list]]] + ["." list] + ["." set]]] [world [file (#+ Path)]]] ["." // #_ ["/#" // #_ - ["#" project] + ["#" profile] ["#." action (#+ Action)] ["#." command (#+ Command)]]]) @@ -115,17 +116,18 @@ #.None (wrap [])))) -(def: #export (do! command project) +(def: #export (do! command profile) (All [a] (-> (Command a) (Command Any))) (do {@ ///action.monad} [#let [fs (java/nio/file/FileSystems::getDefault)] watcher (promise.future (java/nio/file/FileSystem::newWatchService fs)) - targets (|> project + targets (|> profile (get@ #///.sources) + set.to-list (monad.map @ ..targets) (:: @ map list.concat)) _ (monad.map @ (..watch! watcher) targets) - _ (command project)] + _ (command profile)] (loop [_ []] (do @ [?key (..poll! watcher) @@ -133,7 +135,7 @@ (#.Some key) (do @ [_ (promise.future (..drain! watcher)) - _ (command project)] + _ (command profile)] (wrap [])) #.None diff --git a/stdlib/source/program/aedifex/command/build.lux b/stdlib/source/program/aedifex/command/build.lux index 0e5d1e229..f505f1d0a 100644 --- a/stdlib/source/program/aedifex/command/build.lux +++ b/stdlib/source/program/aedifex/command/build.lux @@ -16,11 +16,12 @@ ["%" format (#+ format)]] [collection ["." list ("#@." functor)] - ["." dictionary]]] + ["." dictionary] + ["." set]]] [world ["." file (#+ Path)]]] ["." /// #_ - ["#" project] + ["#" profile] ["#." action] ["#." command (#+ Command)] ["#." local] @@ -55,6 +56,7 @@ (exception: #export no-available-compiler) (exception: #export no-specified-program) +(exception: #export no-specified-target) (type: #export Compiler (#JVM Artifact) @@ -107,18 +109,25 @@ (-> Text (List Text) Text) (|> values (list@map (|>> (format name " "))) (text.join-with " "))) -(def: #export (do! project) +(def: #export (do! profile) (Command [Compiler Path]) - (case (get@ #///.program project) - (#.Some program) + (case [(get@ #///.program profile) + (get@ #///.target profile)] + [#.None _] + (promise@wrap (exception.throw ..no-specified-program [])) + + [_ #.None] + (promise@wrap (exception.throw ..no-specified-target [])) + + [(#.Some program) (#.Some target)] (do ///action.monad [cache (///local.all-cached (file.async file.system) - (get@ #///.dependencies project) + (set.to-list (get@ #///.dependencies profile)) ///dependency.empty) resolution (promise.future - (///dependency.resolve-all (get@ #///.repositories project) - (get@ #///.dependencies project) + (///dependency.resolve-all (set.to-list (get@ #///.repositories profile)) + (set.to-list (get@ #///.dependencies profile)) cache)) _ (///local.cache-all (file.async file.system) resolution) @@ -130,10 +139,10 @@ "program.jar"] (#JS artifact) [(format "node --stack_size=8192 " (///local.path file.system artifact)) "program.js"]) - cache-directory (format working-directory (:: file.system separator) (get@ #///.target project)) + cache-directory (format working-directory (:: file.system separator) target) command (format prefix " build" " " (..plural-parameter "--library" libraries) - " " (..plural-parameter "--source" (get@ #///.sources project)) + " " (..plural-parameter "--source" (set.to-list (get@ #///.sources profile))) " " (..singular-parameter "--target" cache-directory) " " (..singular-parameter "--module" program))] #let [_ (log! "[BUILD STARTED]")] @@ -141,6 +150,4 @@ #let [_ (log! "[BUILD ENDED]")]] (wrap [compiler (format cache-directory (:: file.system separator) output)])) - - #.None - (promise@wrap (exception.throw ..no-specified-program [])))) + )) diff --git a/stdlib/source/program/aedifex/command/deploy.lux b/stdlib/source/program/aedifex/command/deploy.lux index ed6667264..1081322b4 100644 --- a/stdlib/source/program/aedifex/command/deploy.lux +++ b/stdlib/source/program/aedifex/command/deploy.lux @@ -12,7 +12,8 @@ ["%" format (#+ format)] ["." encoding]] [collection - ["." dictionary (#+ Dictionary)]] + ["." dictionary (#+ Dictionary)] + ["." set]] [format ["." binary] ["." tar] @@ -23,7 +24,7 @@ [compositor ["." export]]] ["." /// #_ - ["/" project (#+ Project)] + ["/" profile (#+ Profile)] ["//" upload (#+ User Password)] ["#." action (#+ Action)] ["#." command (#+ Command)] @@ -39,29 +40,33 @@ (format (%.text name) " := " (%.text repo))) (dictionary.entries options))])) -(def: #export (do! repository user password project) +(def: #export (do! repository user password profile) (-> 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)) + (case [(get@ #/.identity profile) + (dictionary.get repository (get@ #/.deploy-repositories profile))] + [#.None _] + (promise@wrap (exception.throw /.no-identity [])) + + [_ #.None] + (promise@wrap (exception.throw ..cannot-find-repository [repository (get@ #/.deploy-repositories profile)])) + + [(#.Some identity) (#.Some repository)] + (let [deploy! (: (-> ///dependency.Type Binary (Action Any)) (function (_ type content) (promise.future (//.upload repository user password - {#///dependency.artifact artifact + {#///dependency.artifact identity #///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)) + (set.to-list (get@ #/.sources profile)))) + pom (promise@wrap (///pom.project profile)) + _ (deploy! ///dependency.pom (|> pom (:: 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)])))) + (wrap []))))) diff --git a/stdlib/source/program/aedifex/local.lux b/stdlib/source/program/aedifex/local.lux index 0a429fdc2..1b8a02f1a 100644 --- a/stdlib/source/program/aedifex/local.lux +++ b/stdlib/source/program/aedifex/local.lux @@ -5,6 +5,7 @@ [control ["." io (#+ IO)] ["." try (#+ Try)] + ["." exception] [concurrency ["." promise (#+ Promise)]] [security @@ -16,7 +17,8 @@ ["." encoding]] [collection ["." list ("#@." monoid)] - ["." dictionary]] + ["." dictionary] + ["." set]] [format ["." binary] ["." tar] @@ -27,7 +29,7 @@ [compositor ["." export]]] ["." // #_ - ["/" project (#+ Project)] + ["/" profile (#+ Profile)] ["#." extension] ["#." pom] ["#." artifact (#+ Artifact)] @@ -67,17 +69,22 @@ (file.get-file promise.monad system file))] (!.use (:: file over-write) [content]))) -(def: #export (install system project) - (-> (file.System Promise) Project (Promise (Try Any))) - (do (try.with promise.monad) - [repository (..guarantee-repository! system (get@ #/.identity project)) - #let [identity (get@ #/.identity project) - artifact-name (format repository (:: system separator) (//artifact.identity identity))] - package (export.library system (get@ #/.sources project)) - _ (..save! system (binary.run tar.writer package) - (format artifact-name "." //dependency.lux-library))] - (..save! system (|> project //pom.project (:: xml.codec encode) encoding.to-utf8) - (format artifact-name //extension.pom)))) +(def: #export (install system profile) + (-> (file.System Promise) Profile (Promise (Try Any))) + (case (get@ #/.identity profile) + (#.Some identity) + (do (try.with promise.monad) + [repository (..guarantee-repository! system identity) + #let [artifact-name (format repository (:: system separator) (//artifact.identity identity))] + package (export.library system (set.to-list (get@ #/.sources profile))) + _ (..save! system (binary.run tar.writer package) + (format artifact-name "." //dependency.lux-library)) + pom (:: promise.monad wrap (//pom.project profile))] + (..save! system (|> pom (:: xml.codec encode) encoding.to-utf8) + (format artifact-name //extension.pom))) + + _ + (:: promise.monad wrap (exception.throw /.no-identity [])))) (def: #export (cache system [artifact type] package) (-> (file.System Promise) Dependency Package (Promise (Try Any))) diff --git a/stdlib/source/program/aedifex/parser.lux b/stdlib/source/program/aedifex/parser.lux index 17191d5cb..87f41f2c6 100644 --- a/stdlib/source/program/aedifex/parser.lux +++ b/stdlib/source/program/aedifex/parser.lux @@ -8,7 +8,8 @@ [data ["." text] [collection - ["." dictionary (#+ Dictionary)]]] + ["." dictionary (#+ Dictionary)] + ["." set (#+ Set)]]] [tool [compiler [meta @@ -16,10 +17,11 @@ [descriptor (#+ Module)]]]]] [world [net (#+ URL)]]] - [// - ["/" project] - ["//." artifact (#+ Artifact)] - ["//." dependency]]) + ["." // #_ + ["/" profile] + ["#." project (#+ Project)] + ["#." artifact (#+ Artifact)] + ["#." dependency]]) (def: (as-input input) (-> (Maybe Code) (List Code)) @@ -115,16 +117,6 @@ (Parser /.Contributor) ..developer) -(def: no-info - /.Info - {#/.url #.None - #/.scm #.None - #/.description #.None - #/.licenses (list) - #/.organization #.None - #/.developers (list) - #/.contributors (list)}) - (def: info (Parser /.Info) (do {@ <>.monad} @@ -162,6 +154,10 @@ (Parser /.Source) .text) +(def: target + (Parser /.Target) + .text) + (def: module (Parser Module) .text) @@ -171,28 +167,70 @@ (.tuple (<>.and .text ..repository))) -(def: #export project - (Parser /.Project) +(def: profile + (Parser /.Profile) (do {@ <>.monad} [input (:: @ map (dictionary.from-list text.hash) (.record (<>.some (<>.and .local-tag - .any))))] + .any)))) + #let [^parents (: (Parser (List /.Name)) + (<>.default (list) + (..plural input "parents" .text))) + ^identity (: (Parser (Maybe Artifact)) + (<>.maybe + (..singular input "identity" ..artifact))) + ^info (: (Parser (Maybe /.Info)) + (<>.maybe + (..singular input "info" ..info))) + ^repositories (: (Parser (Set //dependency.Repository)) + (|> (..plural input "repositories" ..repository) + (:: @ map (set.from-list text.hash)) + (<>.default (set.new text.hash)))) + ^dependencies (: (Parser (Set //dependency.Dependency)) + (|> (..plural input "dependencies" ..dependency) + (:: @ map (set.from-list //dependency.hash)) + (<>.default (set.new //dependency.hash)))) + ^sources (: (Parser (Set /.Source)) + (|> (..plural input "sources" ..source) + (:: @ map (set.from-list text.hash)) + (<>.default (set.from-list text.hash (list /.default-source))))) + ^target (: (Parser (Maybe /.Target)) + (<>.maybe + (..singular input "target" ..target))) + ^program (: (Parser (Maybe Module)) + (<>.maybe + (..singular input "program" ..module))) + ^test (: (Parser (Maybe Module)) + (<>.maybe + (..singular input "test" ..module))) + ^deploy-repositories (: (Parser (Dictionary Text //dependency.Repository)) + (<| (:: @ map (dictionary.from-list text.hash)) + (<>.default (list)) + (..plural input "deploy-repositories" ..deploy-repository)))]] ($_ <>.and - (..singular input "identity" ..artifact) - (<>.default ..no-info - (..singular input "info" ..info)) - (<>.default (list) - (..plural input "repositories" ..repository)) - (<>.default (list) - (..plural input "dependencies" ..dependency)) - (<>.default (list "source") - (..plural input "sources" ..source)) - (<>.default "target" - (..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)) + ^parents + ^identity + ^info + ^repositories + ^dependencies + ^sources + ^target + ^program + ^test + ^deploy-repositories ))) + +(def: #export project + (Parser Project) + (let [default-profile (: (Parser Project) + (:: <>.monad map + (|>> [/.default] (list) (dictionary.from-list text.hash)) + ..profile)) + multi-profile (: (Parser Project) + (:: <>.monad map + (dictionary.from-list text.hash) + (.record (<>.many (<>.and .text + ..profile)))))] + (<>.either multi-profile + default-profile))) diff --git a/stdlib/source/program/aedifex/pom.lux b/stdlib/source/program/aedifex/pom.lux index 794ed7e12..9370620f5 100644 --- a/stdlib/source/program/aedifex/pom.lux +++ b/stdlib/source/program/aedifex/pom.lux @@ -1,15 +1,18 @@ (.module: [lux #* [control - [pipe (#+ case>)]] + [pipe (#+ case>)] + ["." try (#+ Try)] + ["." exception]] [data ["." maybe ("#@." functor)] [format ["_" xml (#+ XML)]] [collection - ["." list ("#@." monoid functor)]]]] + ["." list ("#@." monoid functor)] + ["." set]]]] ["." // #_ - ["/" project] + ["/" profile] ["#." artifact (#+ Artifact)] ["#." dependency (#+ Repository Dependency)]]) @@ -110,11 +113,17 @@ )) (def: #export (project value) - (-> /.Project XML) - (#_.Node ["" "project"] _.attrs - ($_ list@compose - (list ..version) - (..artifact (get@ #/.identity value)) - (|> value (get@ #/.repositories) (list@map ..repository) (..group "repositories") list) - (|> value (get@ #/.dependencies) (list@map ..dependency) (..group "dependencies") list) - ))) + (-> /.Profile (Try XML)) + (case (get@ #/.identity value) + (#.Some identity) + (#try.Success + (#_.Node ["" "project"] _.attrs + ($_ list@compose + (list ..version) + (..artifact identity) + (|> value (get@ #/.repositories) set.to-list (list@map ..repository) (..group "repositories") list) + (|> value (get@ #/.dependencies) set.to-list (list@map ..dependency) (..group "dependencies") list) + ))) + + _ + (exception.throw /.no-identity []))) diff --git a/stdlib/source/program/aedifex/profile.lux b/stdlib/source/program/aedifex/profile.lux new file mode 100644 index 000000000..5e5cb6175 --- /dev/null +++ b/stdlib/source/program/aedifex/profile.lux @@ -0,0 +1,135 @@ +(.module: + [lux (#- Info Source Module Name) + [abstract + [monoid (#+ Monoid)]] + [control + ["." exception (#+ exception:)]] + [data + ["." maybe ("#@." monoid)] + ["." text] + [collection + ["." dictionary (#+ Dictionary)] + ["." list ("#@." monoid)] + ["." set (#+ Set)]]] + [world + [net (#+ URL)] + [file (#+ Path)]] + [tool + [compiler + [meta + [archive + [descriptor (#+ Module)]]]]]] + [// + [artifact (#+ Artifact)] + ["." dependency]]) + +(def: #export file + "project.lux") + +(type: #export Distribution + #Repo + #Manual) + +(type: #export License + [Text + URL + Distribution]) + +(type: #export SCM + URL) + +(type: #export Organization + [Text + URL]) + +(type: #export Email + Text) + +(type: #export Developer + [Text + Email + (Maybe Organization)]) + +(type: #export Contributor + Developer) + +(type: #export Info + {#url (Maybe URL) + #scm (Maybe SCM) + #description (Maybe Text) + #licenses (List License) + #organization (Maybe Organization) + #developers (List Developer) + #contributors (List Contributor)}) + +(def: #export default-info + Info + {#url #.None + #scm #.None + #description #.None + #licenses (list) + #organization #.None + #developers (list) + #contributors (list)}) + +(type: #export Source + Path) + +(def: #export default-source + Source + "source") + +(type: #export Target + Path) + +(def: #export default-target + Target + "target") + +(type: #export Name + Text) + +(def: #export default + Name + "") + +(type: #export Profile + {#parents (List Name) + #identity (Maybe Artifact) + #info (Maybe Info) + #repositories (Set dependency.Repository) + #dependencies (Set dependency.Dependency) + #sources (Set Source) + #target (Maybe Target) + #program (Maybe Module) + #test (Maybe Module) + #deploy-repositories (Dictionary Text dependency.Repository)}) + +(exception: #export no-identity) + +(structure: #export monoid + (Monoid Profile) + + (def: identity + {#parents (list) + #identity #.None + #info #.None + #repositories (set.new text.hash) + #dependencies (set.new dependency.hash) + #sources (set.new text.hash) + #target #.None + #program #.None + #test #.None + #deploy-repositories (dictionary.new text.hash)}) + + (def: (compose override baseline) + {#parents (list@compose (get@ #parents baseline) (get@ #parents override)) + #identity (maybe@compose (get@ #identity override) (get@ #identity baseline)) + #info (maybe@compose (get@ #info override) (get@ #info baseline)) + #repositories (set.union (get@ #repositories baseline) (get@ #repositories override)) + #dependencies (set.union (get@ #dependencies baseline) (get@ #dependencies override)) + #sources (set.union (get@ #sources baseline) (get@ #sources override)) + #target (maybe@compose (get@ #target override) (get@ #target baseline)) + #program (maybe@compose (get@ #program override) (get@ #program baseline)) + #test (maybe@compose (get@ #test override) (get@ #test baseline)) + #deploy-repositories (dictionary.merge (get@ #deploy-repositories override) (get@ #deploy-repositories baseline))})) diff --git a/stdlib/source/program/aedifex/project.lux b/stdlib/source/program/aedifex/project.lux index 20bbda840..81a8de1af 100644 --- a/stdlib/source/program/aedifex/project.lux +++ b/stdlib/source/program/aedifex/project.lux @@ -1,70 +1,53 @@ (.module: - [lux (#- Info Source Module) + [lux (#- Name) + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] [data - ["." text] + ["." text + ["%" format (#+ format)]] [collection - ["." dictionary (#+ Dictionary)]]] - [world - [net (#+ URL)] - [file (#+ Path)]] - [tool - [compiler - [meta - [archive - [descriptor (#+ Module)]]]]]] - [// - [artifact (#+ Artifact)] - ["." dependency]]) - -(def: #export file - "project.lux") - -(type: #export Distribution - #Repo - #Manual) - -(type: #export License - [Text - URL - Distribution]) - -(type: #export SCM - URL) - -(type: #export Organization - [Text - URL]) - -(type: #export Email - Text) - -(type: #export Developer - [Text - Email - (Maybe Organization)]) - -(type: #export Contributor - Developer) - -(type: #export Info - {#url (Maybe URL) - #scm (Maybe SCM) - #description (Maybe Text) - #licenses (List License) - #organization (Maybe Organization) - #developers (List Developer) - #contributors (List Contributor)}) - -(type: #export Source - Path) + ["." dictionary (#+ Dictionary)] + ["." set (#+ Set)] + ["." list ("#@." fold)]]]] + ["." // #_ + ["#" profile (#+ Name Profile)]]) (type: #export Project - {#identity Artifact - #info Info - #repositories (List dependency.Repository) - #dependencies (List dependency.Dependency) - #sources (List Source) - #target Path - #program (Maybe Module) - #test (Maybe Module) - #deploy-repositories (Dictionary Text dependency.Repository)}) + (Dictionary Name Profile)) + +(exception: #export (unknown-profile {name Name}) + (exception.report + ["Name" (%.text name)])) + +(exception: #export (circular-dependency {dependee Name} {dependent Name}) + (exception.report + ["Dependent" (%.text dependent)] + ["Dependee" (%.text dependee)])) + +(def: (profile' lineage project name) + (-> (Set Name) Project Name (Try Profile)) + (case (dictionary.get name project) + (#.Some profile) + (case (list.find (set.member? lineage) + (get@ #//.parents profile)) + (#.Some ouroboros) + (exception.throw ..circular-dependency [ouroboros name]) + + #.None + (do {@ try.monad} + [parents (monad.map @ (profile' (set.add name lineage) project) + (get@ #//.parents profile))] + (wrap (list@fold (function (_ parent child) + (:: //.monoid compose child parent)) + profile + parents)))) + + #.None + (exception.throw ..unknown-profile [name]))) + +(def: #export (profile project name) + (-> Project Name (Try Profile)) + (profile' (set.new text.hash) project name)) diff --git a/stdlib/source/test/lux/control/parser/text.lux b/stdlib/source/test/lux/control/parser/text.lux index 08dddb051..4b207b257 100644 --- a/stdlib/source/test/lux/control/parser/text.lux +++ b/stdlib/source/test/lux/control/parser/text.lux @@ -95,19 +95,19 @@ (..should-fail (text.from-code invalid) /.lower)))) (do {@ random.monad} [expected (:: @ map (n.% 10) random.nat) - invalid (random.char (unicode.set [unicode.aegean-numbers (list)]))] + invalid (random.char (unicode.set [unicode.number-forms (list)]))] (_.cover [/.decimal] (and (..should-pass (:: n.decimal encode expected) /.decimal) (..should-fail (text.from-code invalid) /.decimal)))) (do {@ random.monad} [expected (:: @ map (n.% 8) random.nat) - invalid (random.char (unicode.set [unicode.aegean-numbers (list)]))] + invalid (random.char (unicode.set [unicode.number-forms (list)]))] (_.cover [/.octal] (and (..should-pass (:: n.octal encode expected) /.octal) (..should-fail (text.from-code invalid) /.octal)))) (do {@ random.monad} [expected (:: @ map (n.% 16) random.nat) - invalid (random.char (unicode.set [unicode.aegean-numbers (list)]))] + invalid (random.char (unicode.set [unicode.number-forms (list)]))] (_.cover [/.hexadecimal] (and (..should-pass (:: n.hex encode expected) /.hexadecimal) (..should-fail (text.from-code invalid) /.hexadecimal)))) diff --git a/stdlib/source/test/lux/data/binary.lux b/stdlib/source/test/lux/data/binary.lux index 492fdac24..17f773206 100644 --- a/stdlib/source/test/lux/data/binary.lux +++ b/stdlib/source/test/lux/data/binary.lux @@ -1,16 +1,18 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] - ["r" math/random (#+ Random)] ["_" test (#+ Test)] + [math + ["." random (#+ Random)]] [abstract ["." monad (#+ do)] ["." enum] {[0 #spec] [/ - ["$." equivalence]]}] + ["$." equivalence] + ["$." monoid]]}] [control - ["." try (#+ Try)]] + ["." try (#+ Try)] + ["." exception (#+ Exception)]] [data [number ["." i64] @@ -24,7 +26,7 @@ (-> (Try Bit) Bit) (case result (#try.Failure _) - #0 + false (#try.Success output) output)) @@ -34,59 +36,124 @@ (let [output (/.create size)] (loop [idx 0] (if (n.< size idx) - (do r.monad - [byte r.nat] + (do random.monad + [byte random.nat] (exec (try.assume (/.write/8 idx byte output)) (recur (inc idx)))) - (:: r.monad wrap output))))) + (:: random.monad wrap output))))) -(def: (bits-io bytes read write value) +(def: (throws? exception try) + (All [e a] (-> (Exception e) (Try a) Bit)) + (case try + (#try.Failure error) + (exception.match? exception error) + + (#try.Success _) + false)) + +(def: (binary-io bytes read write value) (-> Nat (-> Nat Binary (Try Nat)) (-> Nat Nat Binary (Try Any)) Nat Bit) (let [binary (/.create bytes) cap (case bytes 8 (dec 0) _ (|> 1 (i64.left-shift (n.* 8 bytes)) dec)) capped-value (i64.and cap value)] - (succeed - (do try.monad - [_ (write 0 value binary) - output (read 0 binary)] - (wrap (n.= capped-value output)))))) + (and (succeed + (do try.monad + [pre (read 0 binary) + _ (write 0 value binary) + post (read 0 binary)] + (wrap (and (n.= 0 pre) + (n.= capped-value post))))) + (throws? /.index-out-of-bounds (read 1 binary)) + (throws? /.index-out-of-bounds (write 1 value binary))))) + +(def: as-list + (-> /.Binary (List Nat)) + (/.fold (function (_ head tail) + (#.Cons head tail)) + (list))) (def: #export test Test - (<| (_.context (%.name (name-of /._))) - (do {@ r.monad} - [#let [gen-size (|> r.nat (:: @ map (|>> (n.% 100) (n.max 8))))] - binary-size gen-size - random-binary (binary binary-size) - value r.nat - #let [gen-idx (|> r.nat (:: @ map (n.% binary-size)))] - [from to] (r.and gen-idx gen-idx) + (<| (_.covering /._) + (do {@ random.monad} + [#let [gen-size (|> random.nat (:: @ map (|>> (n.% 100) (n.max 8))))] + size gen-size + sample (..binary size) + value random.nat + #let [gen-idx (|> random.nat (:: @ map (n.% size)))] + [from to] (random.and gen-idx gen-idx) #let [[from to] [(n.min from to) (n.max from to)]]] - ($_ _.and - ($equivalence.spec /.equivalence (binary binary-size)) - (_.test "Can get size of binary." - (|> random-binary /.size (n.= binary-size))) - (_.test "Can read/write 8-bit values." - (bits-io 1 /.read/8 /.write/8 value)) - (_.test "Can read/write 16-bit values." - (bits-io 2 /.read/16 /.write/16 value)) - (_.test "Can read/write 32-bit values." - (bits-io 4 /.read/32 /.write/32 value)) - (_.test "Can read/write 64-bit values." - (bits-io 8 /.read/64 /.write/64 value)) - (_.test "Can slice binaries." - (let [slice-size (|> to (n.- from) inc) - random-slice (try.assume (/.slice from to random-binary)) - idxs (enum.range n.enum 0 (dec slice-size)) - reader (function (_ binary idx) (/.read/8 idx binary))] - (and (n.= slice-size (/.size random-slice)) - (case [(monad.map try.monad (reader random-slice) idxs) - (monad.map try.monad (|>> (n.+ from) (reader random-binary)) idxs)] - [(#try.Success slice-vals) (#try.Success binary-vals)] - (:: (list.equivalence n.equivalence) = slice-vals binary-vals) + (_.with-cover [/.Binary] + ($_ _.and + (_.with-cover [/.equivalence] + ($equivalence.spec /.equivalence (..binary size))) + (_.with-cover [/.monoid] + ($monoid.spec /.equivalence /.monoid (..binary size))) + (_.cover [/.fold] + (n.= (:: list.fold fold n.+ 0 (..as-list sample)) + (/.fold n.+ 0 sample))) + + (_.cover [/.create] + (:: /.equivalence = + (/.create size) + (/.create size))) + (_.cover [/.size] + (|> (/.create size) /.size (n.= size))) + (_.with-cover [/.index-out-of-bounds] + ($_ _.and + (_.cover [/.read/8 /.write/8] + (..binary-io 1 /.read/8 /.write/8 value)) + (_.cover [/.read/16 /.write/16] + (..binary-io 2 /.read/16 /.write/16 value)) + (_.cover [/.read/32 /.write/32] + (..binary-io 4 /.read/32 /.write/32 value)) + (_.cover [/.read/64 /.write/64] + (..binary-io 8 /.read/64 /.write/64 value)))) + (_.cover [/.slice] + (let [slice-size (|> to (n.- from) inc) + random-slice (try.assume (/.slice from to sample)) + idxs (enum.range n.enum 0 (dec slice-size)) + reader (function (_ binary idx) (/.read/8 idx binary))] + (and (n.= slice-size (/.size random-slice)) + (case [(monad.map try.monad (reader random-slice) idxs) + (monad.map try.monad (|>> (n.+ from) (reader sample)) idxs)] + [(#try.Success slice-vals) (#try.Success binary-vals)] + (:: (list.equivalence n.equivalence) = slice-vals binary-vals) + + _ + #0)))) + (_.cover [/.slice-out-of-bounds] + (and (throws? /.slice-out-of-bounds (/.slice size size sample)) + (throws? /.slice-out-of-bounds (/.slice from size sample)))) + (_.cover [/.inverted-slice] + (or (throws? /.inverted-slice (/.slice to from sample)) + (n.= to from))) + (_.cover [/.drop] + (and (:: /.equivalence = sample (/.drop 0 sample)) + (:: /.equivalence = (/.create 0) (/.drop size sample)) + (case (list.reverse (..as-list sample)) + #.Nil + false + + (#.Cons head tail) + (n.= (list.fold n.+ 0 tail) + (/.fold n.+ 0 (/.drop 1 sample)))))) + (_.cover [/.copy] + (and (case (/.copy size 0 sample 0 (/.create size)) + (#try.Success output) + (and (not (is? sample output)) + (:: /.equivalence = sample output)) - _ - #0)))) - )))) + (#try.Failure _) + false) + (succeed + (do try.monad + [sample/0 (/.read/8 0 sample) + copy (/.copy 1 0 sample 0 (/.create 2)) + copy/0 (/.read/8 0 copy) + copy/1 (/.read/8 1 copy)] + (wrap (and (n.= sample/0 copy/0) + (n.= 0 copy/1))))))) + ))))) -- cgit v1.2.3