diff options
Diffstat (limited to '')
24 files changed, 795 insertions, 569 deletions
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> <type> <header> <format>] - [(exception: #export (<exception> {label <type>}) - (exception.report - [<header> (%.text (<format> 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^ (<text>.many xml-char^))) (<>\map (|>> #Text)))) +(def: null^ + (Parser Any) + (<text>.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 [<options> (template [<char>] + [(^ (char (~~ (static <char>))))] + + [..tab] + [..vertical-tab] + [..space] + [..new-line] + [..carriage-return] + [..form-feed] + )] + (`` (case char + (^or <options>) + 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 [<name> <segments>] - [(def: #export <name> - (..set <segments>))] - - [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 [<name> <segments>] + [(def: #export <name> + (..set <segments>))] + + [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) + (<| <code>.form + (<>.after (<code>.text! ..extension)) + (<>.and <code>.any + <code>.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 [<char> <definition>] + [(def: #export <definition> <char>)] + + ## 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 [<name> <close> <tag> <context>] - [(def: (<name> 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? <close> error) - (#.Right [source' - [where (<tag> (list.reverse stack))]]) - (#.Left [source' error]))))))] +(template [<name> <close> <tag>] + [(template: (<name> 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? <close> error) + (#.Right [source' + [where (<tag> (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 [<non-name-chars> (template [<char>] +(with-expansions [<digits> (as-is "0" "1" "2" "3" "4" "5" "6" "7" "8" "9") + <non-name-chars> (template [<char>] [(~~ (static <char>))] [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]) + <digit-separator> (static ..digit-separator)] + (template: (!if-digit? @char @then @else) + ("lux syntax char case!" @char + [[<digits>] + @then] + + ## else + @else)) + + (template: (!if-digit?+ @char @then @else-options @else) + (`` ("lux syntax char case!" @char + [[<digits> <digit-separator>] + @then + + (~~ (template.splice @else-options))] + + ## else + @else))) + + (`` (template: (!if-name-char?|tail @char @then @else) + ("lux syntax char case!" @char [[<non-name-chars>] - #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 + [[<non-name-chars> <digits>] + @else] -(template: (!name-char? char) - (!strict-name-char? char)) + ## else + @then))) + ) -(template: (!number-output <start> <end> <codec> <tag>) - (case (|> source-code +(template: (!number-output <source-code> <start> <end> <codec> <tag>) + (case (|> <source-code> (!clip <start> <end>) (text.replace-all ..digit-separator "") (\ <codec> decode)) (#.Right output) - (#.Right [[(update@ #.column (|>> (!n/+ (!n/- <start> <end>))) where) + (#.Right [[(let [[where::file where::line where::column] where] + [where::file where::line (!n/+ (!n/- <start> <end>) where::column)]) <end> - source-code] + <source-code>] [where (<tag> output)]]) (#.Left error) - (#.Left [[where <start> source-code] + (#.Left [[where <start> <source-code>] error]))) (def: no-exponent Offset 0) -(with-expansions [<int-output> (as-is (!number-output start end int.decimal #.Int)) - <frac-output> (as-is (!number-output start end frac.decimal #.Frac)) - <failure> (!failure ..parse-frac where offset source-code)] - (def: (parse-frac source-code//size start [where offset source-code]) - (-> Nat Offset (Parser Code)) +(with-expansions [<int-output> (as-is (!number-output source-code start end int.decimal #.Int)) + <frac-output> (as-is (!number-output source-code start end frac.decimal #.Frac)) + <failure> (!failure ..parse-frac where offset source-code) + <frac-separator> (static ..frac-separator) + <signs> (template [<sign>] + [(~~ (static <sign>))] + + [..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 <frac-output>) - (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 <failure>) - (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 <failure>) - (if (!digit?+ char/2) - (recur (!n/+ 3 end) char/0) - <failure>)) - <failure>)) - - ## else - <frac-output>)))) - - (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 <int-output>) - (cond (!digit?+ char) - (recur (!inc end)) - - (!n/= (`` (.char (~~ (static ..frac-separator)))) - char) - (parse-frac source-code//size start [where (!inc end) source-code]) - - ## else - <int-output>)))))) + (!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 <failure>) + (`` ("lux syntax char case!" char/1 + [[<signs>] + (<| (!with-char+ source-code//size source-code (!n/+ 2 end) char/2 <failure>) + (!if-digit?+ char/2 + (recur (!n/+ 3 end) char/0) + [] + <failure>))] + ## else + <failure>))) + <frac-output>)] + + <frac-output>)))) + + (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 <int-output>) + (!if-digit?+ char + (recur (!inc end)) + + [[<frac-separator>] + (parse-frac source-code//size start where (!inc end) source-code)] + + <int-output>)))) + ) (template [<parser> <codec> <tag>] - [(def: (<parser> source-code//size start where offset source-code) - (-> Nat Nat Location Nat Text (Either [Source Text] [Source Code])) + [(template: (<parser> 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 <codec> <tag>)) - (if (!digit?+ g!char) - (recur (!inc g!end)) - (!number-output start g!end <codec> <tag>)))))] + (<| (!with-char+ source-code//size source-code g!end g!char (!number-output source-code start g!end <codec> <tag>)) + (!if-digit?+ g!char + (recur (!inc g!end)) + [] + (!number-output source-code start g!end <codec> <tag>)))))] [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 [<output> (#.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 <output>) - (if (!name-char? char) - (recur (!inc end)) - <output>)))))) + (!if-name-char?|tail char + (recur (!inc end)) + <output>)))))) (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 [<simple> (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 <simple>) (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]]))) <simple>))))) (template: (!parse-full-name @offset @source @where @aliases @tag) @@ -443,7 +465,7 @@ ## [expression ...] ## [form "(" [#* expression] ")"]) -(with-expansions [<consume-1> (as-is [where (!inc offset/0) source-code]) +(with-expansions [<consume-1> (as-is where (!inc offset/0) source-code) <move-1> (as-is [(!forward 1 where) (!inc offset/0) source-code]) <move-2> (as-is [(!forward 1 where) (!inc/2 offset/0) source-code]) <recur> (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 <move-2> 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 [<char> <bit>] - [[<char>] - (#.Right [[(update@ #.column (|>> !inc/2) where) - (!inc offset/1) - source-code] - [where (#.Bit <bit>)]])] - - ["0" #0] - ["1" #1]))] - - ## else - (cond (!name-char?|head char/1) ## Tag - (!parse-full-name offset/1 <move-2> 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 <move-2> 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 [<char> <bit>] + [[<char>] + (#.Right [[(update@ #.column (|>> !inc/2) where) + (!inc offset/1) + source-code] + [where (#.Bit <bit>)]])] + + ["0" #0] + ["1" #1]))] + + ## else + (!if-name-char?|head char/1 + ## Tag + (!parse-full-name offset/1 <move-2> 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 <consume-1> 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 [<consume-1>] 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 [<name> <type> <uri> <parser> <default>] + [(def: (<name> repository artifact) + (-> (Repository Promise) Artifact (Promise (Try <type>))) + (do promise.monad + [project (\ repository download (<uri> artifact))] + (case project + (#try.Success project) + (wrap (|> project + (do> try.monad + [(\ encoding.utf8 decode)] + [(\ xml.codec decode)] + [(<xml>.run <parser>)]))) + + (#try.Failure error) + (wrap (#try.Success <default>)))))] + + [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 (<private> / 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 @@ [<group> "groupId"] [<name> "artifactId"] [<version> "version"] + [<versioning> "versioning"] [<versions> "versions"] [<last-updated> "lastUpdated"] [<metadata> "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 ..<versioning> + 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 (<xml>.somewhere (..text ..<group>)) (<xml>.somewhere (..text ..<name>)) - (<xml>.somewhere (<| (..sub ..<versions>) - (<>.many (..text ..<version>)))) - (<xml>.somewhere ..last-updated-parser) + (<| (..sub ..<versioning>) + ($_ <>.and + (<| <xml>.somewhere + (..sub ..<versions>) + (<>.many (..text ..<version>))) + (<xml>.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) (<text>.embed (<>.codec n.decimal (<text>.many <text>.decimal)) - (..text ..<timestamp>))) + (..text ..<build-number>))) (exception: #export (time-stamp-mismatch {expected Time-Stamp} {actual Text}) (exception.report @@ -226,7 +226,7 @@ (def: (snapshot-parser expected) (-> Value (Parser Type)) - (<| (..sub ..<snapshot-versions>) + (<| (..sub ..<snapshot-version>) (do <>.monad [#let [[version time-stamp build] expected] updated (<xml>.somewhere (..text ..<updated>)) @@ -243,8 +243,8 @@ (do <>.monad [[time-stamp build] (<| <xml>.somewhere (..sub ..<snapshot>) - (<>.and ..time-stamp-parser - ..build-parser)) + (<>.and (<xml>.somewhere ..time-stamp-parser) + (<xml>.somewhere ..build-parser))) last-updated (<xml>.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/set.lux index 1b47c8cdb..21c5a90f1 100644 --- a/stdlib/source/test/lux/data/text/unicode.lux +++ b/stdlib/source/test/lux/data/text/unicode/set.lux @@ -16,16 +16,18 @@ [math ["." random (#+ Random)]]] ["." / #_ - ["#." segment]] + ["/#" // #_ + ["#." segment]]] {1 ["." / - ["." segment]]}) + [// + ["." segment]]]}) (def: #export random (Random /.Set) (do {! random.monad} - [left /segment.random - right /segment.random] + [left //segment.random + right //segment.random] (wrap (/.set [left (list right)])))) (def: #export test @@ -33,13 +35,13 @@ (<| (_.covering /._) (_.for [/.Set]) (do {! random.monad} - [segment /segment.random + [segment //segment.random inside (\ ! map (|>> (n.% (segment.size segment)) (n.+ (segment.start segment))) random.nat) - left /segment.random - right /segment.random + left //segment.random + right //segment.random #let [equivalence (product.equivalence n.equivalence n.equivalence)]] (`` ($_ _.and @@ -87,5 +89,5 @@ [/.full] )) - /segment.test + //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 (<code>.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)))))))) |