From 68b1dd82f23d6648ac3d9075a8f84b0174392945 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 17 Dec 2020 22:03:54 -0400 Subject: More optimizations to the Lux syntax parser. --- stdlib/source/lux/control/parser/xml.lux | 25 +- stdlib/source/lux/data/format/xml.lux | 5 + stdlib/source/lux/data/text.lux | 27 +- stdlib/source/lux/data/text/unicode.lux | 212 ---------- stdlib/source/lux/data/text/unicode/set.lux | 213 ++++++++++ stdlib/source/lux/macro/syntax/common/check.lux | 31 ++ stdlib/source/lux/math/random.lux | 3 +- .../lux/tool/compiler/language/lux/syntax.lux | 469 +++++++++++---------- stdlib/source/lux/type/dynamic.lux | 8 +- stdlib/source/program/aedifex/artifact.lux | 16 +- stdlib/source/program/aedifex/command/deploy.lux | 118 +++++- .../program/aedifex/dependency/resolution.lux | 6 +- stdlib/source/program/aedifex/metadata.lux | 12 +- .../source/program/aedifex/metadata/artifact.lux | 17 +- .../source/program/aedifex/metadata/snapshot.lux | 12 +- stdlib/source/program/aedifex/repository.lux | 104 +++-- stdlib/source/test/lux/control/concurrency/frp.lux | 2 +- .../source/test/lux/control/concurrency/thread.lux | 16 +- stdlib/source/test/lux/control/parser/text.lux | 3 +- stdlib/source/test/lux/data/format/tar.lux | 3 +- stdlib/source/test/lux/data/text.lux | 3 +- stdlib/source/test/lux/data/text/unicode.lux | 91 ---- stdlib/source/test/lux/data/text/unicode/set.lux | 93 ++++ stdlib/source/test/lux/macro/syntax/common.lux | 6 +- .../source/test/lux/macro/syntax/common/check.lux | 35 ++ 25 files changed, 878 insertions(+), 652 deletions(-) delete mode 100644 stdlib/source/lux/data/text/unicode.lux create mode 100644 stdlib/source/lux/data/text/unicode/set.lux create mode 100644 stdlib/source/lux/macro/syntax/common/check.lux delete mode 100644 stdlib/source/test/lux/data/text/unicode.lux create mode 100644 stdlib/source/test/lux/data/text/unicode/set.lux create mode 100644 stdlib/source/test/lux/macro/syntax/common/check.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/control/parser/xml.lux b/stdlib/source/lux/control/parser/xml.lux index bec2b80fe..bc8c6ad93 100644 --- a/stdlib/source/lux/control/parser/xml.lux +++ b/stdlib/source/lux/control/parser/xml.lux @@ -22,14 +22,15 @@ (exception: #export empty-input) (exception: #export unexpected-input) -(template [
] - [(exception: #export ( {label }) - (exception.report - [
(%.text ( label))]))] +(exception: #export (wrong-tag {expected Tag} {actual Tag}) + (exception.report + ["Expected" (%.text (/.tag expected))] + ["Actual" (%.text (/.tag actual))])) - [wrong-tag Tag "Tag" /.tag] - [unknown-attribute Attribute "Attribute" /.attribute] - ) +(exception: #export (unknown-attribute {expected Attribute} {available (List Attribute)}) + (exception.report + ["Expected" (%.text (/.attribute expected))] + ["Available" (exception.enumerate (|>> /.attribute %.text) available)])) (exception: #export (unconsumed-inputs {inputs (List XML)}) (exception.report @@ -50,7 +51,7 @@ (#/.Node _) (exception.throw ..unexpected-input []))))) -(def: #export (node tag) +(def: #export (node expected) (-> Tag (Parser Any)) (function (_ docs) (case docs @@ -62,10 +63,10 @@ (#/.Text _) (exception.throw ..unexpected-input []) - (#/.Node _tag _attributes _children) - (if (name\= tag _tag) + (#/.Node actual _attributes _children) + (if (name\= expected actual) (#try.Success [docs []]) - (exception.throw ..wrong-tag tag)))))) + (exception.throw ..wrong-tag [expected actual])))))) (def: #export tag (Parser Tag) @@ -97,7 +98,7 @@ (#/.Node tag attributes children) (case (dictionary.get name attributes) #.None - (exception.throw ..unknown-attribute [name]) + (exception.throw ..unknown-attribute [name (dictionary.keys attributes)]) (#.Some value) (#try.Success [docs value])))))) diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux index 13f272c4b..4f79fb4c9 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -157,6 +157,10 @@ (..spaced^ (.many xml-char^))) (<>\map (|>> #Text)))) +(def: null^ + (Parser Any) + (.this (text.from-code 0))) + (def: xml^ (Parser XML) (|> (<>.rec @@ -181,6 +185,7 @@ ## cannot be located inside of XML nodes. ## This way, the comments can only be before or after the main document. (<>.before (<>.some comment^)) + (<>.before (<>.some ..null^)) (<>.after (<>.some comment^)) (<>.after (<>.maybe xml-header^)))) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index 81e6e6bd5..042919c24 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -275,14 +275,19 @@ (def: #export (space? char) {#.doc "Checks whether the character is white-space."} (-> Char Bit) - (`` (case char - (^or (^ (char (~~ (static ..tab)))) - (^ (char (~~ (static ..vertical-tab)))) - (^ (char (~~ (static ..space)))) - (^ (char (~~ (static ..new-line)))) - (^ (char (~~ (static ..carriage-return)))) - (^ (char (~~ (static ..form-feed))))) - true - - _ - false))) + (with-expansions [ (template [] + [(^ (char (~~ (static ))))] + + [..tab] + [..vertical-tab] + [..space] + [..new-line] + [..carriage-return] + [..form-feed] + )] + (`` (case char + (^or ) + true + + _ + false)))) diff --git a/stdlib/source/lux/data/text/unicode.lux b/stdlib/source/lux/data/text/unicode.lux deleted file mode 100644 index 2aad089b9..000000000 --- a/stdlib/source/lux/data/text/unicode.lux +++ /dev/null @@ -1,212 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [data - [collection - ["." list ("#\." fold functor)] - ["." set ("#\." equivalence)] - ["." tree #_ - ["#" finger (#+ Tree)]]]] - [type (#+ :by-example) - abstract]] - ["." / #_ - ["#." segment (#+ Segment)] - [// (#+ Char)]]) - -(def: builder - (tree.builder /segment.monoid)) - -(def: :@: - (:by-example [@] - {(tree.Builder @ Segment) - ..builder} - @)) - -(abstract: #export Set - (Tree :@: Segment []) - - (def: #export (compose left right) - (-> Set Set Set) - (:abstraction - (\ builder branch - (:representation left) - (:representation right)))) - - (def: (singleton segment) - (-> Segment Set) - (:abstraction - (\ builder leaf segment []))) - - (def: #export (set [head tail]) - (-> [Segment (List Segment)] Set) - (list\fold ..compose (..singleton head) (list\map ..singleton tail))) - - (def: half/0 - (..set [/segment.basic-latin - (list /segment.latin-1-supplement - /segment.latin-extended-a - /segment.latin-extended-b - /segment.ipa-extensions - /segment.spacing-modifier-letters - /segment.combining-diacritical-marks - /segment.greek-and-coptic - /segment.cyrillic - /segment.cyrillic-supplementary - /segment.armenian - /segment.hebrew - /segment.arabic - /segment.syriac - /segment.thaana - /segment.devanagari - /segment.bengali - /segment.gurmukhi - /segment.gujarati - /segment.oriya - /segment.tamil - /segment.telugu - /segment.kannada - /segment.malayalam - /segment.sinhala - /segment.thai - /segment.lao - /segment.tibetan - /segment.myanmar - /segment.georgian - /segment.hangul-jamo - /segment.ethiopic - /segment.cherokee - /segment.unified-canadian-aboriginal-syllabics - /segment.ogham - /segment.runic - /segment.tagalog - /segment.hanunoo - /segment.buhid - /segment.tagbanwa - /segment.khmer - /segment.mongolian - /segment.limbu - /segment.tai-le - /segment.khmer-symbols - /segment.phonetic-extensions - /segment.latin-extended-additional - /segment.greek-extended - /segment.general-punctuation - /segment.superscripts-and-subscripts - /segment.currency-symbols - /segment.combining-diacritical-marks-for-symbols - /segment.letterlike-symbols - /segment.number-forms - /segment.arrows - /segment.mathematical-operators - /segment.miscellaneous-technical - /segment.control-pictures - /segment.optical-character-recognition - /segment.enclosed-alphanumerics - /segment.box-drawing - )])) - - (def: half/1 - (..set [/segment.block-elements - (list /segment.geometric-shapes - /segment.miscellaneous-symbols - /segment.dingbats - /segment.miscellaneous-mathematical-symbols-a - /segment.supplemental-arrows-a - /segment.braille-patterns - /segment.supplemental-arrows-b - /segment.miscellaneous-mathematical-symbols-b - /segment.supplemental-mathematical-operators - /segment.miscellaneous-symbols-and-arrows - /segment.cjk-radicals-supplement - /segment.kangxi-radicals - /segment.ideographic-description-characters - /segment.cjk-symbols-and-punctuation - /segment.hiragana - /segment.katakana - /segment.bopomofo - /segment.hangul-compatibility-jamo - /segment.kanbun - /segment.bopomofo-extended - /segment.katakana-phonetic-extensions - /segment.enclosed-cjk-letters-and-months - /segment.cjk-compatibility - /segment.cjk-unified-ideographs-extension-a - /segment.yijing-hexagram-symbols - /segment.cjk-unified-ideographs - /segment.yi-syllables - /segment.yi-radicals - /segment.hangul-syllables - ## /segment.high-surrogates - ## /segment.high-private-use-surrogates - ## /segment.low-surrogates - ## /segment.private-use-area - /segment.cjk-compatibility-ideographs - /segment.alphabetic-presentation-forms - /segment.arabic-presentation-forms-a - /segment.variation-selectors - /segment.combining-half-marks - /segment.cjk-compatibility-forms - /segment.small-form-variants - /segment.arabic-presentation-forms-b - /segment.halfwidth-and-fullwidth-forms - /segment.specials - ## /segment.linear-b-syllabary - ## /segment.linear-b-ideograms - ## /segment.aegean-numbers - ## /segment.old-italic - ## /segment.gothic - ## /segment.ugaritic - ## /segment.deseret - ## /segment.shavian - ## /segment.osmanya - ## /segment.cypriot-syllabary - ## /segment.byzantine-musical-symbols - ## /segment.musical-symbols - ## /segment.tai-xuan-jing-symbols - ## /segment.mathematical-alphanumeric-symbols - ## /segment.cjk-unified-ideographs-extension-b - ## /segment.cjk-compatibility-ideographs-supplement - ## /segment.tags - )])) - - (def: #export full - (..compose ..half/0 ..half/1)) - - (def: #export (range set) - (-> Set [Char Char]) - (let [tag (tree.tag (:representation set))] - [(/segment.start tag) - (/segment.end tag)])) - - (def: #export (member? set character) - (-> Set Char Bit) - (loop [tree (:representation set)] - (if (/segment.within? (tree.tag tree) character) - (case (tree.root tree) - (0 #0 _) - true - - (0 #1 left right) - (or (recur left) - (recur right))) - false))) - - (structure: #export equivalence - (Equivalence Set) - - (def: (= reference subject) - (set\= (set.from-list /segment.hash (tree.tags (:representation reference))) - (set.from-list /segment.hash (tree.tags (:representation subject)))))) - ) - -(template [ ] - [(def: #export - (..set ))] - - [ascii [/segment.basic-latin (list)]] - [ascii/alpha [/segment.basic-latin/upper-alpha (list /segment.basic-latin/lower-alpha)]] - [ascii/alpha-num [/segment.basic-latin/upper-alpha (list /segment.basic-latin/lower-alpha /segment.basic-latin/decimal)]] - [ascii/upper-alpha [/segment.basic-latin/upper-alpha (list)]] - [ascii/lower-alpha [/segment.basic-latin/lower-alpha (list)]] - ) diff --git a/stdlib/source/lux/data/text/unicode/set.lux b/stdlib/source/lux/data/text/unicode/set.lux new file mode 100644 index 000000000..f1563d13a --- /dev/null +++ b/stdlib/source/lux/data/text/unicode/set.lux @@ -0,0 +1,213 @@ +(.module: + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [data + [collection + ["." list ("#\." fold functor)] + ["." set ("#\." equivalence)] + ["." tree #_ + ["#" finger (#+ Tree)]]]] + [type (#+ :by-example) + abstract]] + ["." / #_ + ["/#" // #_ + [// (#+ Char)] + ["#." segment (#+ Segment)]]]) + +(def: builder + (tree.builder //segment.monoid)) + +(def: :@: + (:by-example [@] + {(tree.Builder @ Segment) + ..builder} + @)) + +(abstract: #export Set + (Tree :@: Segment []) + + (def: #export (compose left right) + (-> Set Set Set) + (:abstraction + (\ builder branch + (:representation left) + (:representation right)))) + + (def: (singleton segment) + (-> Segment Set) + (:abstraction + (\ builder leaf segment []))) + + (def: #export (set [head tail]) + (-> [Segment (List Segment)] Set) + (list\fold ..compose (..singleton head) (list\map ..singleton tail))) + + (def: half/0 + (..set [//segment.basic-latin + (list //segment.latin-1-supplement + //segment.latin-extended-a + //segment.latin-extended-b + //segment.ipa-extensions + //segment.spacing-modifier-letters + //segment.combining-diacritical-marks + //segment.greek-and-coptic + //segment.cyrillic + //segment.cyrillic-supplementary + //segment.armenian + //segment.hebrew + //segment.arabic + //segment.syriac + //segment.thaana + //segment.devanagari + //segment.bengali + //segment.gurmukhi + //segment.gujarati + //segment.oriya + //segment.tamil + //segment.telugu + //segment.kannada + //segment.malayalam + //segment.sinhala + //segment.thai + //segment.lao + //segment.tibetan + //segment.myanmar + //segment.georgian + //segment.hangul-jamo + //segment.ethiopic + //segment.cherokee + //segment.unified-canadian-aboriginal-syllabics + //segment.ogham + //segment.runic + //segment.tagalog + //segment.hanunoo + //segment.buhid + //segment.tagbanwa + //segment.khmer + //segment.mongolian + //segment.limbu + //segment.tai-le + //segment.khmer-symbols + //segment.phonetic-extensions + //segment.latin-extended-additional + //segment.greek-extended + //segment.general-punctuation + //segment.superscripts-and-subscripts + //segment.currency-symbols + //segment.combining-diacritical-marks-for-symbols + //segment.letterlike-symbols + //segment.number-forms + //segment.arrows + //segment.mathematical-operators + //segment.miscellaneous-technical + //segment.control-pictures + //segment.optical-character-recognition + //segment.enclosed-alphanumerics + //segment.box-drawing + )])) + + (def: half/1 + (..set [//segment.block-elements + (list //segment.geometric-shapes + //segment.miscellaneous-symbols + //segment.dingbats + //segment.miscellaneous-mathematical-symbols-a + //segment.supplemental-arrows-a + //segment.braille-patterns + //segment.supplemental-arrows-b + //segment.miscellaneous-mathematical-symbols-b + //segment.supplemental-mathematical-operators + //segment.miscellaneous-symbols-and-arrows + //segment.cjk-radicals-supplement + //segment.kangxi-radicals + //segment.ideographic-description-characters + //segment.cjk-symbols-and-punctuation + //segment.hiragana + //segment.katakana + //segment.bopomofo + //segment.hangul-compatibility-jamo + //segment.kanbun + //segment.bopomofo-extended + //segment.katakana-phonetic-extensions + //segment.enclosed-cjk-letters-and-months + //segment.cjk-compatibility + //segment.cjk-unified-ideographs-extension-a + //segment.yijing-hexagram-symbols + //segment.cjk-unified-ideographs + //segment.yi-syllables + //segment.yi-radicals + //segment.hangul-syllables + ## //segment.high-surrogates + ## //segment.high-private-use-surrogates + ## //segment.low-surrogates + ## //segment.private-use-area + //segment.cjk-compatibility-ideographs + //segment.alphabetic-presentation-forms + //segment.arabic-presentation-forms-a + //segment.variation-selectors + //segment.combining-half-marks + //segment.cjk-compatibility-forms + //segment.small-form-variants + //segment.arabic-presentation-forms-b + //segment.halfwidth-and-fullwidth-forms + //segment.specials + ## //segment.linear-b-syllabary + ## //segment.linear-b-ideograms + ## //segment.aegean-numbers + ## //segment.old-italic + ## //segment.gothic + ## //segment.ugaritic + ## //segment.deseret + ## //segment.shavian + ## //segment.osmanya + ## //segment.cypriot-syllabary + ## //segment.byzantine-musical-symbols + ## //segment.musical-symbols + ## //segment.tai-xuan-jing-symbols + ## //segment.mathematical-alphanumeric-symbols + ## //segment.cjk-unified-ideographs-extension-b + ## //segment.cjk-compatibility-ideographs-supplement + ## //segment.tags + )])) + + (def: #export full + (..compose ..half/0 ..half/1)) + + (def: #export (range set) + (-> Set [Char Char]) + (let [tag (tree.tag (:representation set))] + [(//segment.start tag) + (//segment.end tag)])) + + (def: #export (member? set character) + (-> Set Char Bit) + (loop [tree (:representation set)] + (if (//segment.within? (tree.tag tree) character) + (case (tree.root tree) + (0 #0 _) + true + + (0 #1 left right) + (or (recur left) + (recur right))) + false))) + + (structure: #export equivalence + (Equivalence Set) + + (def: (= reference subject) + (set\= (set.from-list //segment.hash (tree.tags (:representation reference))) + (set.from-list //segment.hash (tree.tags (:representation subject)))))) + ) + +(template [ ] + [(def: #export + (..set ))] + + [ascii [//segment.basic-latin (list)]] + [ascii/alpha [//segment.basic-latin/upper-alpha (list //segment.basic-latin/lower-alpha)]] + [ascii/alpha-num [//segment.basic-latin/upper-alpha (list //segment.basic-latin/lower-alpha //segment.basic-latin/decimal)]] + [ascii/upper-alpha [//segment.basic-latin/upper-alpha (list)]] + [ascii/lower-alpha [//segment.basic-latin/lower-alpha (list)]] + ) diff --git a/stdlib/source/lux/macro/syntax/common/check.lux b/stdlib/source/lux/macro/syntax/common/check.lux new file mode 100644 index 000000000..dcb8f6c26 --- /dev/null +++ b/stdlib/source/lux/macro/syntax/common/check.lux @@ -0,0 +1,31 @@ +(.module: + [lux #* + ["." meta] + [abstract + [monad (#+ do)]] + [control + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [macro + ["." code]]]) + +(def: extension + "lux check") + +(type: #export Check + {#type Code + #value Code}) + +(def: #export (write (^slots [#type #value])) + (-> Check Code) + (` ((~ (code.text ..extension)) + (~ type) + (~ value)))) + +(def: #export parser + (Parser Check) + (<| .form + (<>.after (.text! ..extension)) + (<>.and .any + .any))) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index 45985a41a..e1f34cd32 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -16,7 +16,8 @@ ["c" complex] ["f" frac]] ["." text (#+ Char) ("#\." monoid) - ["." unicode]] + ["." unicode #_ + ["#" set]]] [collection ["." list ("#\." fold)] ["." array (#+ Array)] diff --git a/stdlib/source/lux/tool/compiler/language/lux/syntax.lux b/stdlib/source/lux/tool/compiler/language/lux/syntax.lux index 2b5cfd4a8..1916cfe15 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/syntax.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/syntax.lux @@ -90,39 +90,50 @@ [!n/- "lux i64 -"] ) -(type: #export Aliases (Dictionary Text Text)) -(def: #export no-aliases Aliases (dictionary.new text.hash)) +(type: #export Aliases + (Dictionary Text Text)) + +(def: #export no-aliases + Aliases + (dictionary.new text.hash)) (def: #export prelude "lux") (def: #export text-delimiter text.double-quote) -(def: #export open-form "(") -(def: #export close-form ")") +(template [ ] + [(def: #export )] + + ## Form delimiters + ["(" open-form] + [")" close-form] -(def: #export open-tuple "[") -(def: #export close-tuple "]") + ## Tuple delimiters + ["[" open-tuple] + ["]" close-tuple] -(def: #export open-record "{") -(def: #export close-record "}") + ## Record delimiters + ["{" open-record] + ["}" close-record] -(def: #export sigil "#") + ["#" sigil] -(def: #export digit-separator ",") + ["," digit-separator] -(def: #export positive-sign "+") -(def: #export negative-sign "-") + ["+" positive-sign] + ["-" negative-sign] -(def: #export frac-separator ".") + ["." frac-separator] -## The parts of a name are separated by a single mark. -## E.g. module.short. -## Only one such mark may be used in an name, since there -## can only be 2 parts to a name (the module [before the -## mark], and the short [after the mark]). -## There are also some extra rules regarding name syntax, -## encoded in the parser. -(def: #export name-separator ".") + ## The parts of a name are separated by a single mark. + ## E.g. module.short. + ## Only one such mark may be used in an name, since there + ## can only be 2 parts to a name (the module [before the + ## mark], and the short [after the mark]). + ## There are also some extra rules regarding name syntax, + ## encoded in the parser. + ["." name-separator] + ) (exception: #export (end-of-file {module Text}) (exception.report @@ -130,8 +141,8 @@ (def: amount-of-input-shown 64) -(def: (input-at start input) - (-> Offset Text Text) +(template: (input-at start input) + ## (-> Offset Text Text) (let [end (|> start (!n/+ amount-of-input-shown) (n.min ("lux text size" input)))] (!clip start end input))) @@ -197,48 +208,42 @@ (!inc offset) source-code]) -(def: close-signal - (template.with-locals [g!close-signal] - (template.text [g!close-signal]))) - -(template [ ] - [(def: ( parse source) - (-> (Parser Code) (Parser Code)) - (let [[where offset source-code] source] - (loop [source (: Source [(!forward 1 where) offset source-code]) - stack (: (List Code) #.Nil)] - (case (parse source) - (#.Right [source' top]) - (recur source' (#.Cons top stack)) - - (#.Left [source' error]) - (if (is? error) - (#.Right [source' - [where ( (list.reverse stack))]]) - (#.Left [source' error]))))))] +(template [ ] + [(template: ( parse where offset source-code) + ## (-> (Parser Code) (Parser Code)) + (loop [source (: Source [(!forward 1 where) offset source-code]) + stack (: (List Code) #.Nil)] + (case (parse source) + (#.Right [source' top]) + (recur source' (#.Cons top stack)) + + (#.Left [source' error]) + (if (is? error) + (#.Right [source' + [where ( (list.reverse stack))]]) + (#.Left [source' error])))))] ## Form and tuple syntax is mostly the same, differing only in the ## delimiters involved. ## They may have an arbitrary number of arbitrary Code nodes as elements. - [parse-form ..close-form #.Form "Form"] - [parse-tuple ..close-tuple #.Tuple "Tuple"] + [parse-form ..close-form #.Form] + [parse-tuple ..close-tuple #.Tuple] ) -(def: (parse-record parse source) - (-> (Parser Code) (Parser Code)) - (let [[where offset source-code] source] - (loop [source (: Source [(!forward 1 where) offset source-code]) - stack (: (List [Code Code]) #.Nil)] - (case (parse source) - (#.Right [sourceF field]) - (!letE [sourceFV value] (parse sourceF) - (recur sourceFV (#.Cons [field value] stack))) - - (#.Left [source' error]) - (if (is? ..close-record error) - (#.Right [source' - [where (#.Record (list.reverse stack))]]) - (#.Left [source' error])))))) +(template: (parse-record parse where offset source-code) + ## (-> (Parser Code) (Parser Code)) + (loop [source (: Source [(!forward 1 where) offset source-code]) + stack (: (List [Code Code]) #.Nil)] + (case (parse source) + (#.Right [sourceF field]) + (!letE [sourceFV value] (parse sourceF) + (recur sourceFV (#.Cons [field value] stack))) + + (#.Left [source' error]) + (if (is? ..close-record error) + (#.Right [source' + [where (#.Record (list.reverse stack))]]) + (#.Left [source' error]))))) (template: (!guarantee-no-new-lines where offset source-code content body) (case ("lux text index" 0 (static text.new-line) content) @@ -253,185 +258,202 @@ (-> Location Nat Text (Either [Source Text] [Source Code])) (case ("lux text index" offset (static ..text-delimiter) source-code) (#.Some g!end) - (let [g!content (!clip offset g!end source-code)] - (<| (!guarantee-no-new-lines where offset source-code g!content) - (#.Right [[(let [size (!n/- offset g!end)] - (update@ #.column (|>> (!n/+ size) (!n/+ 2)) where)) - (!inc g!end) - source-code] - [where - (#.Text g!content)]]))) + (<| (let [g!content (!clip offset g!end source-code)]) + (!guarantee-no-new-lines where offset source-code g!content) + (#.Right [[(let [size (!n/- offset g!end)] + (update@ #.column (|>> (!n/+ size) (!n/+ 2)) where)) + (!inc g!end) + source-code] + [where + (#.Text g!content)]])) _ (!failure ..parse-text where offset source-code))) -(def: digit-bottom Nat (!dec (char "0"))) -(def: digit-top Nat (!inc (char "9"))) - -(template: (!digit? char) - (and (!i/< (:coerce Int char) (:coerce Int (static ..digit-bottom))) - (!i/< (:coerce Int (static ..digit-top)) (:coerce Int char)))) - -(`` (template: (!digit?+ char) - (or (!digit? char) - ("lux i64 =" (.char (~~ (static ..digit-separator))) char)))) - -(with-expansions [ (template [] +(with-expansions [ (as-is "0" "1" "2" "3" "4" "5" "6" "7" "8" "9") + (template [] [(~~ (static ))] [text.space] - [text.new-line] + [text.new-line] [text.carriage-return] [..name-separator] [..open-form] [..close-form] [..open-tuple] [..close-tuple] [..open-record] [..close-record] [..text-delimiter] - [..sigil])] - (`` (template: (!strict-name-char? char) - ("lux syntax char case!" char + [..sigil]) + (static ..digit-separator)] + (template: (!if-digit? @char @then @else) + ("lux syntax char case!" @char + [[] + @then] + + ## else + @else)) + + (template: (!if-digit?+ @char @then @else-options @else) + (`` ("lux syntax char case!" @char + [[ ] + @then + + (~~ (template.splice @else-options))] + + ## else + @else))) + + (`` (template: (!if-name-char?|tail @char @then @else) + ("lux syntax char case!" @char [[] - #0] + @else] ## else - #1)))) + @then))) -(template: (!name-char?|head char) - (and (!strict-name-char? char) - (not (!digit? char)))) + (`` (template: (!if-name-char?|head @char @then @else) + ("lux syntax char case!" @char + [[ ] + @else] -(template: (!name-char? char) - (!strict-name-char? char)) + ## else + @then))) + ) -(template: (!number-output ) - (case (|> source-code +(template: (!number-output ) + (case (|> (!clip ) (text.replace-all ..digit-separator "") (\ decode)) (#.Right output) - (#.Right [[(update@ #.column (|>> (!n/+ (!n/- ))) where) + (#.Right [[(let [[where::file where::line where::column] where] + [where::file where::line (!n/+ (!n/- ) where::column)]) - source-code] + ] [where ( output)]]) (#.Left error) - (#.Left [[where source-code] + (#.Left [[where ] error]))) (def: no-exponent Offset 0) -(with-expansions [ (as-is (!number-output start end int.decimal #.Int)) - (as-is (!number-output start end frac.decimal #.Frac)) - (!failure ..parse-frac where offset source-code)] - (def: (parse-frac source-code//size start [where offset source-code]) - (-> Nat Offset (Parser Code)) +(with-expansions [ (as-is (!number-output source-code start end int.decimal #.Int)) + (as-is (!number-output source-code start end frac.decimal #.Frac)) + (!failure ..parse-frac where offset source-code) + (static ..frac-separator) + (template [] + [(~~ (static ))] + + [..positive-sign] + [..negative-sign])] + (template: (parse-frac source-code//size start where offset source-code) + ## (-> Nat Offset (Parser Code)) (loop [end offset - exponent ..no-exponent] + exponent (static ..no-exponent)] (<| (!with-char+ source-code//size source-code end char/0 ) - (cond (!digit?+ char/0) - (recur (!inc end) exponent) - - (and (or (!n/= (char "e") char/0) - (!n/= (char "E") char/0)) - (is? ..no-exponent exponent)) - (<| (!with-char+ source-code//size source-code (!inc end) char/1 ) - (if (or (!n/= (`` (char (~~ (static ..positive-sign)))) char/1) - (!n/= (`` (char (~~ (static ..negative-sign)))) char/1)) - (<| (!with-char+ source-code//size source-code (!n/+ 2 end) char/2 ) - (if (!digit?+ char/2) - (recur (!n/+ 3 end) char/0) - )) - )) - - ## else - )))) - - (def: (parse-signed start [where offset source-code]) - (-> Offset (Parser Code)) - (let [source-code//size ("lux text size" source-code)] - (loop [end offset] - (<| (!with-char+ source-code//size source-code end char ) - (cond (!digit?+ char) - (recur (!inc end)) - - (!n/= (`` (.char (~~ (static ..frac-separator)))) - char) - (parse-frac source-code//size start [where (!inc end) source-code]) - - ## else - )))))) + (!if-digit?+ char/0 + (recur (!inc end) exponent) + + [["e" "E"] + (if (is? (static ..no-exponent) exponent) + (<| (!with-char+ source-code//size source-code (!inc end) char/1 ) + (`` ("lux syntax char case!" char/1 + [[] + (<| (!with-char+ source-code//size source-code (!n/+ 2 end) char/2 ) + (!if-digit?+ char/2 + (recur (!n/+ 3 end) char/0) + [] + ))] + ## else + ))) + )] + + )))) + + (template: (parse-signed source-code//size start where offset source-code) + ## (-> Nat Offset (Parser Code)) + (loop [end offset] + (<| (!with-char+ source-code//size source-code end char ) + (!if-digit?+ char + (recur (!inc end)) + + [[] + (parse-frac source-code//size start where (!inc end) source-code)] + + )))) + ) (template [ ] - [(def: ( source-code//size start where offset source-code) - (-> Nat Nat Location Nat Text (Either [Source Text] [Source Code])) + [(template: ( source-code//size start where offset source-code) + ## (-> Nat Nat Location Nat Text (Either [Source Text] [Source Code])) (loop [g!end offset] - (<| (!with-char+ source-code//size source-code g!end g!char (!number-output start g!end )) - (if (!digit?+ g!char) - (recur (!inc g!end)) - (!number-output start g!end )))))] + (<| (!with-char+ source-code//size source-code g!end g!char (!number-output source-code start g!end )) + (!if-digit?+ g!char + (recur (!inc g!end)) + [] + (!number-output source-code start g!end )))))] [parse-nat n.decimal #.Nat] [parse-rev rev.decimal #.Rev] ) (template: (!parse-signed source-code//size offset where source-code @aliases @end) - (let [g!offset/1 (!inc offset)] - (<| (!with-char+ source-code//size source-code g!offset/1 g!char/1 @end) - (if (!digit? g!char/1) - (parse-signed offset [where (!inc/2 offset) source-code]) - (!parse-full-name offset [where (!inc offset) source-code] where @aliases #.Identifier))))) + (<| (let [g!offset/1 (!inc offset)]) + (!with-char+ source-code//size source-code g!offset/1 g!char/1 @end) + (!if-digit? g!char/1 + (parse-signed source-code//size offset where (!inc/2 offset) source-code) + (!parse-full-name offset [where (!inc offset) source-code] where @aliases #.Identifier)))) (with-expansions [ (#.Right [[(update@ #.column (|>> (!n/+ (!n/- start end))) where) end source-code] (!clip start end source-code)])] - (def: (parse-name-part start [where offset source-code]) - (-> Offset (Parser Text)) + (template: (parse-name-part start where offset source-code) + ## (-> Offset (Parser Text)) (let [source-code//size ("lux text size" source-code)] (loop [end offset] (<| (!with-char+ source-code//size source-code end char ) - (if (!name-char? char) - (recur (!inc end)) - )))))) + (!if-name-char?|tail char + (recur (!inc end)) + )))))) (template: (!parse-half-name @offset @char @module) - (cond (!name-char?|head @char) - (!letE [source' name] (..parse-name-part @offset [where (!inc @offset) source-code]) - (#.Right [source' [@module name]])) - - ## else - (!failure ..!parse-half-name where @offset source-code))) - -(`` (def: (parse-short-name current-module [where offset/0 source-code]) - (-> Text (Parser Name)) - (<| (!with-char source-code offset/0 char/0 - (!end-of-file where offset/0 source-code current-module)) + (!if-name-char?|head @char + (!letE [source' name] (..parse-name-part @offset where (!inc @offset) source-code) + (#.Right [source' [@module name]])) + (!failure ..!parse-half-name where @offset source-code))) + +(`` (def: (parse-short-name source-code//size current-module [where offset/0 source-code]) + (-> Nat Text (Parser Name)) + (<| (!with-char+ source-code//size source-code offset/0 char/0 + (!end-of-file where offset/0 source-code current-module)) (if (!n/= (char (~~ (static ..name-separator))) char/0) - (let [offset/1 (!inc offset/0)] - (<| (!with-char source-code offset/1 char/1 - (!end-of-file where offset/1 source-code current-module)) - (!parse-half-name offset/1 char/1 current-module))) - (!parse-half-name offset/0 char/0 ..prelude))))) - -(template: (!parse-short-name @current-module @source @where @tag) - (!letE [source' name] (..parse-short-name @current-module @source) + (<| (let [offset/1 (!inc offset/0)]) + (!with-char+ source-code//size source-code offset/1 char/1 + (!end-of-file where offset/1 source-code current-module)) + (!parse-half-name offset/1 char/1 current-module)) + (!parse-half-name offset/0 char/0 (static ..prelude)))))) + +(template: (!parse-short-name source-code//size @current-module @source @where @tag) + (!letE [source' name] (..parse-short-name source-code//size @current-module @source) (#.Right [source' [@where (@tag name)]]))) (with-expansions [ (as-is (#.Right [source' ["" simple]]))] (`` (def: (parse-full-name aliases start source) (-> Aliases Offset (Parser Name)) - (<| (!letE [source' simple] (..parse-name-part start source)) + (<| (!letE [source' simple] (let [[where offset source-code] source] + (..parse-name-part start where offset source-code))) (let [[where' offset' source-code'] source']) (!with-char source-code' offset' char/separator ) (if (!n/= (char (~~ (static ..name-separator))) char/separator) - (let [offset'' (!inc offset')] - (!letE [source'' complex] (..parse-name-part offset'' [(!forward 1 where') offset'' source-code']) - (if ("lux text =" "" complex) - (let [[where offset source-code] source] - (!failure ..parse-full-name where offset source-code)) - (#.Right [source'' [(|> aliases - (dictionary.get simple) - (maybe.default simple)) - complex]])))) + (<| (let [offset'' (!inc offset')]) + (!letE [source'' complex] (..parse-name-part offset'' (!forward 1 where') offset'' source-code')) + (if ("lux text =" "" complex) + (let [[where offset source-code] source] + (!failure ..parse-full-name where offset source-code)) + (#.Right [source'' [(|> aliases + (dictionary.get simple) + (maybe.default simple)) + complex]]))) ))))) (template: (!parse-full-name @offset @source @where @aliases @tag) @@ -443,7 +465,7 @@ ## [expression ...] ## [form "(" [#* expression] ")"]) -(with-expansions [ (as-is [where (!inc offset/0) source-code]) +(with-expansions [ (as-is where (!inc offset/0) source-code) (as-is [(!forward 1 where) (!inc offset/0) source-code]) (as-is [(!forward 1 where) (!inc/2 offset/0) source-code]) (as-is (parse current-module aliases source-code//size)) @@ -488,47 +510,48 @@ ## Special code [(~~ (static ..sigil))] - (let [offset/1 (!inc offset/0)] - (<| (!with-char+ source-code//size source-code offset/1 char/1 - (!end-of-file where offset/1 source-code current-module)) - ("lux syntax char case!" char/1 - [[(~~ (static ..name-separator))] - (!parse-short-name current-module where #.Tag) - - ## Single-line comment - [(~~ (static ..sigil))] - (case ("lux text index" (!inc offset/1) (static text.new-line) source-code) - (#.Some end) - (recur (!vertical where end source-code)) - - _ - (!end-of-file where offset/1 source-code current-module)) - - (~~ (template [ ] - [[] - (#.Right [[(update@ #.column (|>> !inc/2) where) - (!inc offset/1) - source-code] - [where (#.Bit )]])] - - ["0" #0] - ["1" #1]))] - - ## else - (cond (!name-char?|head char/1) ## Tag - (!parse-full-name offset/1 where aliases #.Tag) - - ## else - (!failure ..parse where offset/0 source-code))))) + (<| (let [offset/1 (!inc offset/0)]) + (!with-char+ source-code//size source-code offset/1 char/1 + (!end-of-file where offset/1 source-code current-module)) + ("lux syntax char case!" char/1 + [[(~~ (static ..name-separator))] + (!parse-short-name source-code//size current-module where #.Tag) + + ## Single-line comment + [(~~ (static ..sigil))] + (case ("lux text index" (!inc offset/1) (static text.new-line) source-code) + (#.Some end) + (recur (!vertical where end source-code)) + + _ + (!end-of-file where offset/1 source-code current-module)) + + (~~ (template [ ] + [[] + (#.Right [[(update@ #.column (|>> !inc/2) where) + (!inc offset/1) + source-code] + [where (#.Bit )]])] + + ["0" #0] + ["1" #1]))] + + ## else + (!if-name-char?|head char/1 + ## Tag + (!parse-full-name offset/1 where aliases #.Tag) + (!failure ..parse where offset/0 source-code)))) ## Coincidentally (= ..name-separator ..frac-separator) - [(~~ (static ..name-separator))] - (let [offset/1 (!inc offset/0)] - (<| (!with-char+ source-code//size source-code offset/1 char/1 - (!end-of-file where offset/1 source-code current-module)) - (if (!digit? char/1) - (parse-rev source-code//size offset/0 where (!inc offset/1) source-code) - (!parse-short-name current-module [where offset/1 source-code] where #.Identifier)))) + [(~~ (static ..name-separator)) + ## (~~ (static ..frac-separator)) + ] + (<| (let [offset/1 (!inc offset/0)]) + (!with-char+ source-code//size source-code offset/1 char/1 + (!end-of-file where offset/1 source-code current-module)) + (!if-digit? char/1 + (parse-rev source-code//size offset/0 where (!inc offset/1) source-code) + (!parse-short-name source-code//size current-module [where offset/1 source-code] where #.Identifier))) [(~~ (static ..positive-sign)) (~~ (static ..negative-sign))] @@ -536,11 +559,11 @@ (!end-of-file where offset/0 source-code current-module))] ## else - (if (!digit? char/0) - ## Natural number - (parse-nat source-code//size offset/0 where (!inc offset/0) source-code) - ## Identifier - (!parse-full-name offset/0 where aliases #.Identifier)) + (!if-digit? char/0 + ## Natural number + (parse-nat source-code//size offset/0 where (!inc offset/0) source-code) + ## Identifier + (!parse-full-name offset/0 [] where aliases #.Identifier)) ))) ))) )) diff --git a/stdlib/source/lux/type/dynamic.lux b/stdlib/source/lux/type/dynamic.lux index 3d0d96ee9..9d9027e72 100644 --- a/stdlib/source/lux/type/dynamic.lux +++ b/stdlib/source/lux/type/dynamic.lux @@ -23,21 +23,21 @@ {#.doc "A value coupled with its type, so it can be checked later."} - (def: dynamic-abstraction (-> [Type Any] Dynamic) (|>> :abstraction)) - (def: dynamic-representation (-> Dynamic [Type Any]) (|>> :representation)) + (def: abstraction (-> [Type Any] Dynamic) (|>> :abstraction)) + (def: representation (-> Dynamic [Type Any]) (|>> :representation)) (syntax: #export (:dynamic value) {#.doc (doc (: Dynamic (:dynamic 123)))} (with-gensyms [g!value] (wrap (list (` (let [(~ g!value) (~ value)] - ((~! ..dynamic-abstraction) [(:of (~ g!value)) (~ g!value)]))))))) + ((~! ..abstraction) [(:of (~ g!value)) (~ g!value)]))))))) (syntax: #export (:check type value) {#.doc (doc (: (try.Try Nat) (:check Nat (:dynamic 123))))} (with-gensyms [g!type g!value] - (wrap (list (` (let [[(~ g!type) (~ g!value)] ((~! ..dynamic-representation) (~ value))] + (wrap (list (` (let [[(~ g!type) (~ g!value)] ((~! ..representation) (~ value))] (: ((~! try.Try) (~ type)) (if (\ (~! type.equivalence) (~' =) (.type (~ type)) (~ g!type)) diff --git a/stdlib/source/program/aedifex/artifact.lux b/stdlib/source/program/aedifex/artifact.lux index a26e70e50..e4fe812f1 100644 --- a/stdlib/source/program/aedifex/artifact.lux +++ b/stdlib/source/program/aedifex/artifact.lux @@ -2,8 +2,9 @@ [lux (#- Name) [abstract [equivalence (#+ Equivalence)] - ["." hash (#+ Hash)]] + [hash (#+ Hash)]] [data + ["." product] ["." text ["%" format (#+ Format)]] [collection @@ -29,7 +30,7 @@ (def: #export hash (Hash Artifact) - ($_ hash.product + ($_ product.hash text.hash text.hash text.hash @@ -61,12 +62,15 @@ ..identity-separator (..identity value))) +(def: #export (directory separator group) + (-> Text Group Text) + (|> group + (text.split-all-with ..group-separator) + (text.join-with separator))) + (def: (address separator artifact) (-> Text Artifact Text) - (let [directory (%.format (|> artifact - (get@ #group) - (text.split-all-with ..group-separator) - (text.join-with separator)) + (let [directory (%.format (..directory separator (get@ #group artifact)) separator (get@ #name artifact) separator diff --git a/stdlib/source/program/aedifex/command/deploy.lux b/stdlib/source/program/aedifex/command/deploy.lux index dbe4a88cb..4e33b145a 100644 --- a/stdlib/source/program/aedifex/command/deploy.lux +++ b/stdlib/source/program/aedifex/command/deploy.lux @@ -3,11 +3,16 @@ [abstract [monad (#+ do)]] [control + [pipe (#+ do>)] + ["." try (#+ Try)] [concurrency - ["." promise (#+ Promise) ("#\." monad)]]] + ["." promise (#+ Promise) ("#\." monad)]] + ["<>" parser + ["<.>" xml]]] [data [binary (#+ Binary)] [text + ["%" format (#+ format)] ["." encoding]] [collection ["." set]] @@ -15,6 +20,8 @@ ["." binary] ["." tar] ["." xml]]] + [time + ["." instant (#+ Instant)]] [world ["." file] ["." console (#+ Console)]]] @@ -24,28 +31,107 @@ ["." // #_ ["#." clean] ["/#" // #_ - [repository (#+ Identity Repository)] [command (#+ Command)] ["/" profile] ["#." action (#+ Action)] ["#." pom] ["#." hash] + ["#." repository (#+ Identity Repository)] + ["#." metadata + ["#/." artifact] + ["#/." snapshot]] ["#." artifact (#+ Artifact) - ["#/." extension (#+ Extension)]]]]) + ["#/." extension (#+ Extension)] + ["#/." type]]]]) + +(def: epoch + Instant + (instant.from-millis +0)) + +(template [ ] + [(def: ( repository artifact) + (-> (Repository Promise) Artifact (Promise (Try ))) + (do promise.monad + [project (\ repository download ( artifact))] + (case project + (#try.Success project) + (wrap (|> project + (do> try.monad + [(\ encoding.utf8 decode)] + [(\ xml.codec decode)] + [(.run )]))) + + (#try.Failure error) + (wrap (#try.Success )))))] + + [read-project-metadata ///metadata/artifact.Metadata ///metadata.project ///metadata/artifact.parser + (let [(^slots [#///artifact.group #///artifact.name #///artifact.version]) artifact] + {#///metadata/artifact.group group + #///metadata/artifact.name name + #///metadata/artifact.versions (list) + #///metadata/artifact.last-updated ..epoch})] + [read-version-metadata ///metadata/snapshot.Metadata ///metadata.version ///metadata/snapshot.parser + (let [(^slots [#///artifact.group #///artifact.name #///artifact.version]) artifact] + {#///metadata/snapshot.group group + #///metadata/snapshot.name name + #///metadata/snapshot.version version + #///metadata/snapshot.versioning {#///metadata/snapshot.time-stamp ..epoch + #///metadata/snapshot.build 0 + #///metadata/snapshot.snapshot (list)}})] + ) + +(def: snapshot-artifacts + (List ///artifact/type.Type) + (list ///artifact/type.pom + (format ///artifact/type.pom ///artifact/extension.sha-1) + (format ///artifact/type.pom ///artifact/extension.md5) + ///artifact/type.lux-library + (format ///artifact/type.lux-library ///artifact/extension.sha-1) + (format ///artifact/type.lux-library ///artifact/extension.md5))) (def: #export (do! console repository fs identity artifact profile) (-> (Console Promise) (Repository Promise) (file.System Promise) Identity Artifact (Command Any)) (let [deploy! (: (-> Extension Binary (Action Any)) - (\ repository upload identity artifact))] - (do {! ///action.monad} - [library (|> profile - (get@ #/.sources) - set.to-list - (export.library fs) - (\ ! map (binary.run tar.writer))) - pom (promise\wrap (///pom.write profile)) - _ (deploy! ///artifact/extension.pom (|> pom (\ xml.codec encode) encoding.to-utf8)) - _ (deploy! ///artifact/extension.lux-library library) - _ (deploy! ///artifact/extension.sha-1 (///hash.data (///hash.sha-1 library))) - _ (deploy! ///artifact/extension.md5 (///hash.data (///hash.md5 library)))] - (console.write-line //clean.success console)))) + (|>> (///repository.uri artifact) + (\ repository upload identity))) + fully-deploy! (: (-> Extension Binary (Action Any)) + (function (_ extension payload) + (do ///action.monad + [_ (deploy! extension payload) + _ (deploy! (format extension ///artifact/extension.sha-1) + (///hash.data (///hash.sha-1 payload))) + _ (deploy! (format extension ///artifact/extension.md5) + (///hash.data (///hash.md5 payload)))] + (wrap [])))) + (^slots [#///artifact.group #///artifact.name #///artifact.version]) artifact] + (do promise.monad + [now (promise.future instant.now)] + (do {! ///action.monad} + [project (..read-project-metadata repository artifact) + snapshot (..read-version-metadata repository artifact) + pom (\ ! map (|>> (\ xml.codec encode) (\ encoding.utf8 encode)) + (promise\wrap (///pom.write profile))) + library (|> profile + (get@ #/.sources) + set.to-list + (export.library fs) + (\ ! map (binary.run tar.writer))) + + _ (fully-deploy! ///artifact/extension.pom pom) + _ (fully-deploy! ///artifact/extension.lux-library library) + _ (|> snapshot + (set@ [#///metadata/snapshot.versioning #///metadata/snapshot.time-stamp] now) + (update@ [#///metadata/snapshot.versioning #///metadata/snapshot.build] inc) + (set@ [#///metadata/snapshot.versioning #///metadata/snapshot.snapshot] ..snapshot-artifacts) + ///metadata/snapshot.write + (\ xml.codec encode) + (\ encoding.utf8 encode) + (\ repository upload identity (///metadata.version artifact))) + _ (|> project + (set@ #///metadata/artifact.versions (list version)) + (set@ #///metadata/artifact.last-updated now) + ///metadata/artifact.write + (\ xml.codec encode) + (\ encoding.utf8 encode) + (\ repository upload identity (///metadata.project artifact)))] + (console.write-line //clean.success console))))) diff --git a/stdlib/source/program/aedifex/dependency/resolution.lux b/stdlib/source/program/aedifex/dependency/resolution.lux index e8b0f2dba..2131495b9 100644 --- a/stdlib/source/program/aedifex/dependency/resolution.lux +++ b/stdlib/source/program/aedifex/dependency/resolution.lux @@ -58,7 +58,7 @@ (Exception [Dependency Text]) (Promise (Try (///hash.Hash h))))) (do (try.with promise.monad) - [actual (\ repository download artifact extension)] + [actual (\ repository download (///repository.uri artifact extension))] (\ promise.monad wrap (do try.monad [output (\ encoding.utf8 decode actual) @@ -72,14 +72,14 @@ (let [[artifact type] dependency extension (///artifact/extension.extension type)] (do (try.with promise.monad) - [library (\ repository download artifact extension) + [library (\ repository download (///repository.uri artifact extension)) sha-1 (..verified-hash dependency library repository artifact ///artifact/extension.sha-1 ///hash.sha-1 ///hash.sha-1-codec ..sha-1-does-not-match) md5 (..verified-hash dependency library repository artifact ///artifact/extension.md5 ///hash.md5 ///hash.md5-codec ..md5-does-not-match) - pom (\ repository download artifact ///artifact/extension.pom)] + pom (\ repository download (///repository.uri artifact ///artifact/extension.pom))] (\ promise.monad wrap (do try.monad [pom (\ encoding.utf8 decode pom) diff --git a/stdlib/source/program/aedifex/metadata.lux b/stdlib/source/program/aedifex/metadata.lux index 937fea4a3..11a792528 100644 --- a/stdlib/source/program/aedifex/metadata.lux +++ b/stdlib/source/program/aedifex/metadata.lux @@ -7,22 +7,22 @@ [file (#+ Path)] [net ["." uri (#+ URI)]]]] - ["." // + [// ["." artifact (#+ Artifact)]]) (def: #export file Path "maven-metadata.xml") -(def: (project separator artifact) +(def: (project' separator artifact) (-> Text Artifact Text) (format (artifact.directory separator (get@ #artifact.group artifact)) separator (get@ #artifact.name artifact))) -(def: (version separator artifact) +(def: (version' separator artifact) (-> Text Artifact Text) - (format (..project separator artifact) + (format (..project' separator artifact) separator (get@ #artifact.version artifact))) @@ -32,6 +32,6 @@ (let [/ uri.separator] (format ( / artifact) / ..file)))] - [for-project ..project] - [for-version ..version] + [project ..project'] + [version ..version'] ) diff --git a/stdlib/source/program/aedifex/metadata/artifact.lux b/stdlib/source/program/aedifex/metadata/artifact.lux index 1f8068111..aa7b9abce 100644 --- a/stdlib/source/program/aedifex/metadata/artifact.lux +++ b/stdlib/source/program/aedifex/metadata/artifact.lux @@ -61,6 +61,7 @@ [ "groupId"] [ "artifactId"] [ "version"] + [ "versioning"] [ "versions"] [ "lastUpdated"] [ "metadata"] @@ -87,8 +88,10 @@ xml.attributes (list (..write-group (get@ #group value)) (..write-name (get@ #name value)) - (..write-versions (get@ #versions value)) - (..write-last-updated (get@ #last-updated value))))) + (#xml.Node .. + xml.attributes + (list (..write-versions (get@ #versions value)) + (..write-last-updated (get@ #last-updated value))))))) (def: (sub tag parser) (All [a] (-> xml.Tag (Parser a) (Parser a))) @@ -136,9 +139,13 @@ ($_ <>.and (.somewhere (..text ..)) (.somewhere (..text ..)) - (.somewhere (<| (..sub ..) - (<>.many (..text ..)))) - (.somewhere ..last-updated-parser) + (<| (..sub ..) + ($_ <>.and + (<| .somewhere + (..sub ..) + (<>.many (..text ..))) + (.somewhere ..last-updated-parser) + )) ))) (def: #export equivalence diff --git a/stdlib/source/program/aedifex/metadata/snapshot.lux b/stdlib/source/program/aedifex/metadata/snapshot.lux index a94ac33c4..1919d06ca 100644 --- a/stdlib/source/program/aedifex/metadata/snapshot.lux +++ b/stdlib/source/program/aedifex/metadata/snapshot.lux @@ -212,7 +212,7 @@ (Parser Build) (.embed (<>.codec n.decimal (.many .decimal)) - (..text ..))) + (..text ..))) (exception: #export (time-stamp-mismatch {expected Time-Stamp} {actual Text}) (exception.report @@ -226,7 +226,7 @@ (def: (snapshot-parser expected) (-> Value (Parser Type)) - (<| (..sub ..) + (<| (..sub ..) (do <>.monad [#let [[version time-stamp build] expected] updated (.somewhere (..text ..)) @@ -243,8 +243,8 @@ (do <>.monad [[time-stamp build] (<| .somewhere (..sub ..) - (<>.and ..time-stamp-parser - ..build-parser)) + (<>.and (.somewhere ..time-stamp-parser) + (.somewhere ..build-parser))) last-updated (.somewhere ..last-updated-parser) _ (<>.assert (exception.construct ..time-stamp-mismatch [time-stamp (instant-format last-updated)]) (\ instant.equivalence = time-stamp last-updated)) @@ -268,7 +268,7 @@ #version version #versioning versioning})))) -(def: versioning +(def: versioning-equivalence (Equivalence Versioning) ($_ product.equivalence instant.equivalence @@ -282,5 +282,5 @@ text.equivalence text.equivalence text.equivalence - ..versioning + ..versioning-equivalence )) diff --git a/stdlib/source/program/aedifex/repository.lux b/stdlib/source/program/aedifex/repository.lux index 7ec522a10..c351e9d0c 100644 --- a/stdlib/source/program/aedifex/repository.lux +++ b/stdlib/source/program/aedifex/repository.lux @@ -17,9 +17,15 @@ ["." encoding]] [number ["n" nat]]] + [tool + [compiler + ["." version] + ["." language #_ + ["#/." lux #_ + ["#" version]]]]] [world [net (#+ URL) - ["." uri]]]] + ["." uri (#+ URI)]]]] ["." // #_ ["#." artifact (#+ Artifact) ["#/." extension (#+ Extension)]]]) @@ -38,38 +44,36 @@ #password Password}) (signature: #export (Repository !) - (: (-> Artifact Extension (! (Try Binary))) + (: (-> URI (! (Try Binary))) download) - (: (-> Identity Artifact Extension Binary (! (Try Any))) + (: (-> Identity URI Binary (! (Try Any))) upload)) (def: #export (async repository) (-> (Repository IO) (Repository Promise)) (structure - (def: (download artifact extension) - (promise.future (\ repository download artifact extension))) + (def: (download uri) + (promise.future (\ repository download uri))) - (def: (upload identity artifact extension content) - (promise.future (\ repository upload identity artifact extension content))) + (def: (upload identity uri content) + (promise.future (\ repository upload identity uri content))) )) (signature: #export (Simulation s) - (: (-> Artifact Extension s - (Try [s Binary])) + (: (-> URI s (Try [s Binary])) on-download) - (: (-> Identity Artifact Extension Binary s - (Try s)) + (: (-> Identity URI Binary s (Try s)) on-upload)) (def: #export (mock simulation init) (All [s] (-> (Simulation s) s (Repository Promise))) (let [state (stm.var init)] (structure - (def: (download artifact extension) + (def: (download uri) (stm.commit (do {! stm.monad} [|state| (stm.read state)] - (case (\ simulation on-download artifact extension |state|) + (case (\ simulation on-download uri |state|) (#try.Success [|state| output]) (do ! [_ (stm.write |state| state)] @@ -78,11 +82,11 @@ (#try.Failure error) (wrap (#try.Failure error)))))) - (def: (upload identity artifact extension content) + (def: (upload identity uri content) (stm.commit (do {! stm.monad} [|state| (stm.read state)] - (case (\ simulation on-upload identity artifact extension content |state|) + (case (\ simulation on-upload identity uri content |state|) (#try.Success |state|) (do ! [_ (stm.write |state| state)] @@ -98,6 +102,8 @@ ["#::." (close [] #io #try void)]) +(import: java/io/InputStream) + (import: java/io/OutputStream ["#::." (flush [] #io #try void) @@ -107,6 +113,7 @@ ["#::." (setDoOutput [boolean] #io #try void) (setRequestProperty [java/lang/String java/lang/String] #io #try void) + (getInputStream [] #io #try java/io/InputStream) (getOutputStream [] #io #try java/io/OutputStream)]) (import: java/net/HttpURLConnection @@ -117,8 +124,7 @@ (import: java/net/URL ["#::." (new [java/lang/String]) - (openConnection [] #io #try java/net/URLConnection) - (openStream [] #io #try java/io/InputStream)]) + (openConnection [] #io #try java/net/URLConnection)]) (import: java/util/Base64$Encoder ["#::." @@ -128,8 +134,6 @@ ["#::." (#static getEncoder [] java/util/Base64$Encoder)]) -(import: java/io/InputStream) - (import: java/io/BufferedInputStream ["#::." (new [java/io/InputStream]) @@ -141,42 +145,50 @@ (def: (basic-auth user password) (-> User Password Text) - (format "Basic " (java/util/Base64$Encoder::encodeToString (encoding.to-utf8 (format user ":" password)) + (format "Basic " (java/util/Base64$Encoder::encodeToString (\ encoding.utf8 encode (format user ":" password)) (java/util/Base64::getEncoder)))) -(def: (url address artifact extension) - (-> Address Artifact Extension URL) - (format address uri.separator (//artifact.uri artifact) extension)) +(def: #export (uri artifact extension) + (-> Artifact Extension URI) + (format (//artifact.uri artifact) extension)) (def: buffer-size (n.* 512 1,024)) +(def: user-agent + (format "LuxAedifex/" (version.format language/lux.version))) + (structure: #export (remote address) (All [s] (-> Address (Repository IO))) - (def: (download artifact extension) - (let [url (..url address artifact extension)] - (do {! (try.with io.monad)} - [input (|> (java/net/URL::new url) - java/net/URL::openStream - (\ ! map (|>> java/io/BufferedInputStream::new))) - #let [buffer (binary.create ..buffer-size)]] - (loop [output (\ binary.monoid identity)] - (do ! - [bytes-read (java/io/BufferedInputStream::read buffer +0 (.int ..buffer-size) input)] - (case bytes-read - -1 (do ! - [_ (java/lang/AutoCloseable::close input)] - (wrap output)) - _ (if (n.= ..buffer-size bytes-read) - (recur (\ binary.monoid compose output buffer)) - (do ! - [chunk (\ io.monad wrap (binary.slice 0 (.nat bytes-read) buffer))] - (recur (\ binary.monoid compose output chunk)))))))))) - - (def: (upload [user password] artifact extension content) + (def: (download uri) + (do {! (try.with io.monad)} + [connection (|> (format address uri) + java/net/URL::new + java/net/URL::openConnection) + #let [connection (:coerce java/net/HttpURLConnection connection)] + _ (java/net/HttpURLConnection::setRequestMethod "GET" connection) + _ (java/net/URLConnection::setRequestProperty "User-Agent" ..user-agent connection) + input (|> connection + java/net/URLConnection::getInputStream + (\ ! map (|>> java/io/BufferedInputStream::new))) + #let [buffer (binary.create ..buffer-size)]] + (loop [output (\ binary.monoid identity)] + (do ! + [bytes-read (java/io/BufferedInputStream::read buffer +0 (.int ..buffer-size) input)] + (case bytes-read + -1 (do ! + [_ (java/lang/AutoCloseable::close input)] + (wrap output)) + _ (if (n.= ..buffer-size bytes-read) + (recur (\ binary.monoid compose output buffer)) + (do ! + [chunk (\ io.monad wrap (binary.slice 0 (.nat bytes-read) buffer))] + (recur (\ binary.monoid compose output chunk))))))))) + + (def: (upload [user password] uri content) (do (try.with io.monad) - [connection (|> (..url address artifact extension) + [connection (|> (format address uri) java/net/URL::new java/net/URL::openConnection) #let [connection (:coerce java/net/HttpURLConnection connection)] @@ -189,6 +201,6 @@ _ (java/lang/AutoCloseable::close stream) code (java/net/HttpURLConnection::getResponseCode connection)] (case code - +200 (wrap []) + +201 (wrap []) _ (\ io.monad wrap (exception.throw ..deployment-failure [code]))))) ) diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux index 3e0aee4f0..933a599c0 100644 --- a/stdlib/source/test/lux/control/concurrency/frp.lux +++ b/stdlib/source/test/lux/control/concurrency/frp.lux @@ -171,7 +171,7 @@ actual)))) (let [polling-delay 1 amount-of-polls 5 - wiggle-room ($_ n.* amount-of-polls 2 polling-delay) + wiggle-room ($_ n.* amount-of-polls 4 polling-delay) total-delay (|> polling-delay (n.* amount-of-polls) (n.+ wiggle-room))] diff --git a/stdlib/source/test/lux/control/concurrency/thread.lux b/stdlib/source/test/lux/control/concurrency/thread.lux index 210ff4b1d..f8abf6a84 100644 --- a/stdlib/source/test/lux/control/concurrency/thread.lux +++ b/stdlib/source/test/lux/control/concurrency/thread.lux @@ -26,7 +26,8 @@ (do {! random.monad} [dummy random.nat expected random.nat - delay (|> random.nat (\ ! map (n.% 100)))] + delay (\ ! map (|>> (n.% 5) (n.+ 5)) + random.nat)] ($_ _.and (_.cover [/.parallelism] (n.> 0 /.parallelism)) @@ -37,10 +38,15 @@ (/.schedule delay (do io.monad [execution-time instant.now] (atom.write [execution-time expected] box)))) - _ (promise.wait delay) + _ (promise.wait (n.* 2 delay)) [execution-time actual] (promise.future (atom.read box))] (_.cover' [/.schedule] - (and (i.>= (.int delay) - (duration.to-millis (instant.span reference-time execution-time))) - (n.= expected actual))))) + (let [expected-delay! + (i.>= (.int delay) + (duration.to-millis (instant.span reference-time execution-time))) + + correct-value! + (n.= expected actual)] + (and expected-delay! + correct-value!))))) )))) diff --git a/stdlib/source/test/lux/control/parser/text.lux b/stdlib/source/test/lux/control/parser/text.lux index 7c1f5d932..dd5f4d6a8 100644 --- a/stdlib/source/test/lux/control/parser/text.lux +++ b/stdlib/source/test/lux/control/parser/text.lux @@ -11,7 +11,8 @@ ["." maybe] ["." text ("#\." equivalence) ["%" format (#+ format)] - ["." unicode + ["." unicode #_ + ["#" set] ["#/." segment]]] [number ["n" nat]] diff --git a/stdlib/source/test/lux/data/format/tar.lux b/stdlib/source/test/lux/data/format/tar.lux index 73ccec27f..92f5915c7 100644 --- a/stdlib/source/test/lux/data/format/tar.lux +++ b/stdlib/source/test/lux/data/format/tar.lux @@ -15,7 +15,8 @@ ["." text ("#\." equivalence) ["%" format (#+ format)] ["." encoding] - ["." unicode + ["." unicode #_ + ["#" set] ["#/." segment]]] [number ["n" nat] diff --git a/stdlib/source/test/lux/data/text.lux b/stdlib/source/test/lux/data/text.lux index b9dfdb1a9..c751e6a78 100644 --- a/stdlib/source/test/lux/data/text.lux +++ b/stdlib/source/test/lux/data/text.lux @@ -24,7 +24,8 @@ ["#." encoding] ["#." format] ["#." regex] - ["#." unicode]] + ["#." unicode #_ + ["#" set]]] {1 ["." /]}) diff --git a/stdlib/source/test/lux/data/text/unicode.lux b/stdlib/source/test/lux/data/text/unicode.lux deleted file mode 100644 index 1b47c8cdb..000000000 --- a/stdlib/source/test/lux/data/text/unicode.lux +++ /dev/null @@ -1,91 +0,0 @@ -(.module: - [lux #* - ["_" test (#+ Test)] - [abstract - [monad (#+ do)] - {[0 #spec] - [/ - ["$." equivalence]]}] - [data - ["." product] - ["." bit ("#\." equivalence)] - [number - ["n" nat]] - [collection - ["." set ("#\." equivalence)]]] - [math - ["." random (#+ Random)]]] - ["." / #_ - ["#." segment]] - {1 - ["." / - ["." segment]]}) - -(def: #export random - (Random /.Set) - (do {! random.monad} - [left /segment.random - right /segment.random] - (wrap (/.set [left (list right)])))) - -(def: #export test - Test - (<| (_.covering /._) - (_.for [/.Set]) - (do {! random.monad} - [segment /segment.random - inside (\ ! map - (|>> (n.% (segment.size segment)) - (n.+ (segment.start segment))) - random.nat) - left /segment.random - right /segment.random - #let [equivalence (product.equivalence n.equivalence - n.equivalence)]] - (`` ($_ _.and - (_.for [/.equivalence] - ($equivalence.spec /.equivalence ..random)) - - (_.cover [/.range] - (let [[start end] (/.range (/.set [left (list right)]))] - (and (n.= (n.min (segment.start left) - (segment.start right)) - start) - (n.= (n.max (segment.end left) - (segment.end right)) - end)))) - (_.cover [/.member?] - (bit\= (segment.within? segment inside) - (/.member? (/.set [segment (list)]) inside))) - (_.cover [/.compose] - (\ equivalence = - [(n.min (segment.start left) - (segment.start right)) - (n.max (segment.end left) - (segment.end right))] - (/.range (/.compose (/.set [left (list)]) - (/.set [right (list)]))))) - (_.cover [/.set] - (\ equivalence = - (/.range (/.compose (/.set [left (list)]) - (/.set [right (list)]))) - (/.range (/.set [left (list right)])))) - (~~ (template [] - [(do random.monad - [char (random.char ) - #let [[start end] (/.range )]] - (_.cover [] - (and (/.member? char) - (not (/.member? (dec start))) - (not (/.member? (inc end))))))] - - [/.ascii] - [/.ascii/alpha] - [/.ascii/alpha-num] - [/.ascii/lower-alpha] - [/.ascii/upper-alpha] - [/.full] - )) - - /segment.test - ))))) diff --git a/stdlib/source/test/lux/data/text/unicode/set.lux b/stdlib/source/test/lux/data/text/unicode/set.lux new file mode 100644 index 000000000..21c5a90f1 --- /dev/null +++ b/stdlib/source/test/lux/data/text/unicode/set.lux @@ -0,0 +1,93 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + {[0 #spec] + [/ + ["$." equivalence]]}] + [data + ["." product] + ["." bit ("#\." equivalence)] + [number + ["n" nat]] + [collection + ["." set ("#\." equivalence)]]] + [math + ["." random (#+ Random)]]] + ["." / #_ + ["/#" // #_ + ["#." segment]]] + {1 + ["." / + [// + ["." segment]]]}) + +(def: #export random + (Random /.Set) + (do {! random.monad} + [left //segment.random + right //segment.random] + (wrap (/.set [left (list right)])))) + +(def: #export test + Test + (<| (_.covering /._) + (_.for [/.Set]) + (do {! random.monad} + [segment //segment.random + inside (\ ! map + (|>> (n.% (segment.size segment)) + (n.+ (segment.start segment))) + random.nat) + left //segment.random + right //segment.random + #let [equivalence (product.equivalence n.equivalence + n.equivalence)]] + (`` ($_ _.and + (_.for [/.equivalence] + ($equivalence.spec /.equivalence ..random)) + + (_.cover [/.range] + (let [[start end] (/.range (/.set [left (list right)]))] + (and (n.= (n.min (segment.start left) + (segment.start right)) + start) + (n.= (n.max (segment.end left) + (segment.end right)) + end)))) + (_.cover [/.member?] + (bit\= (segment.within? segment inside) + (/.member? (/.set [segment (list)]) inside))) + (_.cover [/.compose] + (\ equivalence = + [(n.min (segment.start left) + (segment.start right)) + (n.max (segment.end left) + (segment.end right))] + (/.range (/.compose (/.set [left (list)]) + (/.set [right (list)]))))) + (_.cover [/.set] + (\ equivalence = + (/.range (/.compose (/.set [left (list)]) + (/.set [right (list)]))) + (/.range (/.set [left (list right)])))) + (~~ (template [] + [(do random.monad + [char (random.char ) + #let [[start end] (/.range )]] + (_.cover [] + (and (/.member? char) + (not (/.member? (dec start))) + (not (/.member? (inc end))))))] + + [/.ascii] + [/.ascii/alpha] + [/.ascii/alpha-num] + [/.ascii/lower-alpha] + [/.ascii/upper-alpha] + [/.full] + )) + + //segment.test + ))))) diff --git a/stdlib/source/test/lux/macro/syntax/common.lux b/stdlib/source/test/lux/macro/syntax/common.lux index 998671dd5..9fcb10006 100644 --- a/stdlib/source/test/lux/macro/syntax/common.lux +++ b/stdlib/source/test/lux/macro/syntax/common.lux @@ -27,7 +27,9 @@ ["#." reader] ["#." writer]]} ["." /// #_ - ["#." code]]) + ["#." code]] + ["." / #_ + ["#." check]]) (def: annotations-equivalence (Equivalence /.Annotations) @@ -132,4 +134,6 @@ (#try.Failure error) false)))) + + /check.test ))) diff --git a/stdlib/source/test/lux/macro/syntax/common/check.lux b/stdlib/source/test/lux/macro/syntax/common/check.lux new file mode 100644 index 000000000..63d042620 --- /dev/null +++ b/stdlib/source/test/lux/macro/syntax/common/check.lux @@ -0,0 +1,35 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try] + ["<>" parser + ["<.>" code]]] + [math + ["." random (#+ Random)]] + [macro + ["." code ("#\." equivalence)]]] + {1 + ["." /]} + ["$." //// #_ + ["#." code]]) + +(def: #export test + Test + (<| (_.covering /._) + (_.for [/.Check]) + (do random.monad + [type $////code.random + value $////code.random] + (_.cover [/.write /.parser] + (case (.run /.parser + (list (/.write {#/.type type + #/.value value}))) + (#try.Failure _) + false + + (#try.Success check) + (and (code\= type (get@ #/.type check)) + (code\= value (get@ #/.value check)))))))) -- cgit v1.2.3