diff options
Diffstat (limited to 'stdlib')
31 files changed, 972 insertions, 660 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 8a64392e4..f45bab179 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -644,7 +644,7 @@ ## (type: Lux ## {#info Info ## #source Source -## #location Location +## #location Location ## #current-module (Maybe Text) ## #modules (List [Text Module]) ## #scopes (List Scope) diff --git a/stdlib/source/lux/abstract/hash.lux b/stdlib/source/lux/abstract/hash.lux index ae1290edc..fabe5be6d 100644 --- a/stdlib/source/lux/abstract/hash.lux +++ b/stdlib/source/lux/abstract/hash.lux @@ -1,7 +1,7 @@ (.module: [lux #*] [// - ["." equivalence (#+ Equivalence)]]) + [equivalence (#+ Equivalence)]]) (signature: #export (Hash a) {#.doc (doc "A way to produce hash-codes for a type's instances." diff --git a/stdlib/source/lux/data/text/unicode/segment.lux b/stdlib/source/lux/data/text/unicode/block.lux index a2507cc1e..a4844258a 100644 --- a/stdlib/source/lux/data/text/unicode/segment.lux +++ b/stdlib/source/lux/data/text/unicode/block.lux @@ -13,11 +13,11 @@ abstract]] [/// (#+ Char)]) -(abstract: #export Segment +(abstract: #export Block (Interval Char) (structure: #export monoid - (Monoid Segment) + (Monoid Block) (def: identity (:abstraction (interval.between n.enum n\top n\bottom))) @@ -31,39 +31,39 @@ (n.max (\ left top) (\ right top))))))) - (def: #export (segment start end) - (-> Char Char Segment) + (def: #export (block start end) + (-> Char Char Block) (:abstraction (interval.between n.enum (n.min start end) (n.max start end)))) (template [<name> <slot>] [(def: #export <name> - (-> Segment Char) + (-> Block Char) (|>> :representation (get@ <slot>)))] [start #interval.bottom] [end #interval.top] ) - (def: #export (size segment) - (-> Segment Nat) - (let [start (get@ #interval.bottom (:representation segment)) - end (get@ #interval.top (:representation segment))] + (def: #export (size block) + (-> Block Nat) + (let [start (get@ #interval.bottom (:representation block)) + end (get@ #interval.top (:representation block))] (|> end (n.- start) inc))) - (def: #export (within? segment char) - (All [a] (-> Segment Char Bit)) - (interval.within? (:representation segment) char)) + (def: #export (within? block char) + (All [a] (-> Block Char Bit)) + (interval.within? (:representation block) char)) ) (structure: #export equivalence - (Equivalence Segment) + (Equivalence Block) (def: (= reference subject) (and (n.= (..start reference) (..start subject)) (n.= (..end reference) (..end subject))))) (structure: #export hash - (Hash Segment) + (Hash Block) (def: &equivalence ..equivalence) (def: (hash value) @@ -71,9 +71,9 @@ (..end value)))) (template [<name> <start> <end>] - [(def: #export <name> Segment (..segment (hex <start>) (hex <end>)))] + [(def: #export <name> Block (..block (hex <start>) (hex <end>)))] - ## Normal segments + ## Normal blocks [basic-latin "0000" "007F"] [latin-1-supplement "00A0" "00FF"] [latin-extended-a "0100" "017F"] @@ -197,7 +197,7 @@ ## [cjk-compatibility-ideographs-supplement "2F800" "2FA1F"] ## [tags "E0000" "E007F"] - ## Specialized segments + ## Specialized blocks [basic-latin/decimal "0030" "0039"] [basic-latin/upper-alpha "0041" "005A"] [basic-latin/lower-alpha "0061" "007A"] diff --git a/stdlib/source/lux/data/text/unicode/set.lux b/stdlib/source/lux/data/text/unicode/set.lux index f1563d13a..8d350a28b 100644 --- a/stdlib/source/lux/data/text/unicode/set.lux +++ b/stdlib/source/lux/data/text/unicode/set.lux @@ -13,19 +13,19 @@ ["." / #_ ["/#" // #_ [// (#+ Char)] - ["#." segment (#+ Segment)]]]) + ["#." block (#+ Block)]]]) (def: builder - (tree.builder //segment.monoid)) + (tree.builder //block.monoid)) (def: :@: (:by-example [@] - {(tree.Builder @ Segment) + {(tree.Builder @ Block) ..builder} @)) (abstract: #export Set - (Tree :@: Segment []) + (Tree :@: Block []) (def: #export (compose left right) (-> Set Set Set) @@ -34,156 +34,163 @@ (:representation left) (:representation right)))) - (def: (singleton segment) - (-> Segment Set) + (def: (singleton block) + (-> Block Set) (:abstraction - (\ builder leaf segment []))) + (\ builder leaf block []))) (def: #export (set [head tail]) - (-> [Segment (List Segment)] Set) + (-> [Block (List Block)] 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: #export character + Set + (..set [//block.basic-latin + (list //block.latin-1-supplement + //block.latin-extended-a + //block.latin-extended-b + //block.ipa-extensions + //block.spacing-modifier-letters + //block.combining-diacritical-marks + //block.greek-and-coptic + //block.cyrillic + //block.cyrillic-supplementary + //block.armenian + //block.hebrew + //block.arabic + //block.syriac + //block.thaana + //block.devanagari + //block.bengali + //block.gurmukhi + //block.gujarati + //block.oriya + //block.tamil + //block.telugu + //block.kannada + //block.malayalam + //block.sinhala + //block.thai + //block.lao + //block.tibetan + //block.myanmar + //block.georgian + //block.hangul-jamo + //block.ethiopic + //block.cherokee + //block.unified-canadian-aboriginal-syllabics + //block.ogham + //block.runic + //block.tagalog + //block.hanunoo + //block.buhid + //block.tagbanwa + //block.khmer + //block.mongolian + //block.limbu + //block.tai-le + //block.khmer-symbols + //block.phonetic-extensions + //block.latin-extended-additional + //block.greek-extended + //block.general-punctuation + //block.superscripts-and-subscripts + //block.currency-symbols + //block.combining-diacritical-marks-for-symbols + //block.letterlike-symbols + //block.number-forms + //block.arrows + //block.mathematical-operators + //block.miscellaneous-technical + //block.control-pictures + //block.optical-character-recognition + //block.enclosed-alphanumerics + //block.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 + //block.block-elements + //block.geometric-shapes + //block.miscellaneous-symbols + //block.dingbats + //block.miscellaneous-mathematical-symbols-a + //block.supplemental-arrows-a + //block.braille-patterns + //block.supplemental-arrows-b + //block.miscellaneous-mathematical-symbols-b + //block.supplemental-mathematical-operators + //block.miscellaneous-symbols-and-arrows + //block.cjk-radicals-supplement + //block.kangxi-radicals + //block.ideographic-description-characters + //block.cjk-symbols-and-punctuation + //block.hiragana + //block.katakana + //block.bopomofo + //block.hangul-compatibility-jamo + //block.kanbun + //block.bopomofo-extended + //block.katakana-phonetic-extensions + //block.enclosed-cjk-letters-and-months + //block.cjk-compatibility + //block.cjk-unified-ideographs-extension-a + //block.yijing-hexagram-symbols + //block.cjk-unified-ideographs + //block.yi-syllables + //block.yi-radicals + //block.hangul-syllables )])) + (def: #export non-character + Set + (..set [//block.high-surrogates + (list //block.high-private-use-surrogates + //block.low-surrogates + //block.private-use-area + //block.cjk-compatibility-ideographs + //block.alphabetic-presentation-forms + //block.arabic-presentation-forms-a + //block.variation-selectors + //block.combining-half-marks + //block.cjk-compatibility-forms + //block.small-form-variants + //block.arabic-presentation-forms-b + //block.halfwidth-and-fullwidth-forms + //block.specials + ## //block.linear-b-syllabary + ## //block.linear-b-ideograms + ## //block.aegean-numbers + ## //block.old-italic + ## //block.gothic + ## //block.ugaritic + ## //block.deseret + ## //block.shavian + ## //block.osmanya + ## //block.cypriot-syllabary + ## //block.byzantine-musical-symbols + ## //block.musical-symbols + ## //block.tai-xuan-jing-symbols + ## //block.mathematical-alphanumeric-symbols + ## //block.cjk-unified-ideographs-extension-b + ## //block.cjk-compatibility-ideographs-supplement + ## //block.tags + )])) + (def: #export full - (..compose ..half/0 ..half/1)) + Set + ($_ ..compose + ..character + ..non-character + )) (def: #export (range set) (-> Set [Char Char]) (let [tag (tree.tag (:representation set))] - [(//segment.start tag) - (//segment.end tag)])) + [(//block.start tag) + (//block.end tag)])) (def: #export (member? set character) (-> Set Char Bit) (loop [tree (:representation set)] - (if (//segment.within? (tree.tag tree) character) + (if (//block.within? (tree.tag tree) character) (case (tree.root tree) (0 #0 _) true @@ -197,17 +204,17 @@ (Equivalence Set) (def: (= reference subject) - (set\= (set.from-list //segment.hash (tree.tags (:representation reference))) - (set.from-list //segment.hash (tree.tags (:representation subject)))))) + (set\= (set.from-list //block.hash (tree.tags (:representation reference))) + (set.from-list //block.hash (tree.tags (:representation subject)))))) ) -(template [<name> <segments>] +(template [<name> <blocks>] [(def: #export <name> - (..set <segments>))] + (..set <blocks>))] - [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)]] + [ascii [//block.basic-latin (list)]] + [ascii/alpha [//block.basic-latin/upper-alpha (list //block.basic-latin/lower-alpha)]] + [ascii/alpha-num [//block.basic-latin/upper-alpha (list //block.basic-latin/lower-alpha //block.basic-latin/decimal)]] + [ascii/upper-alpha [//block.basic-latin/upper-alpha (list)]] + [ascii/lower-alpha [//block.basic-latin/lower-alpha (list)]] ) diff --git a/stdlib/source/lux/macro/syntax/common.lux b/stdlib/source/lux/macro/syntax/common.lux index 15c9a1fc4..2a1469c2d 100644 --- a/stdlib/source/lux/macro/syntax/common.lux +++ b/stdlib/source/lux/macro/syntax/common.lux @@ -1,6 +1,6 @@ (.module: {#.doc (.doc "Commons syntax readers and writers." "The goal is to be able to reuse common syntax in macro definitions across libraries.")} - [lux (#- Definition)]) + [lux #*]) (type: #export Declaration {#declaration-name Text @@ -13,13 +13,6 @@ Annotations (list)) -(type: #export Definition - {#definition-name Text - #definition-type (Maybe Code) - #definition-value Code - #definition-anns Annotations - #definition-args (List Text)}) - (type: #export Typed-Input {#input-binding Code #input-type Code}) diff --git a/stdlib/source/lux/macro/syntax/common/check.lux b/stdlib/source/lux/macro/syntax/common/check.lux index dcb8f6c26..081e394b0 100644 --- a/stdlib/source/lux/macro/syntax/common/check.lux +++ b/stdlib/source/lux/macro/syntax/common/check.lux @@ -2,11 +2,14 @@ [lux #* ["." meta] [abstract + [equivalence (#+ Equivalence)] [monad (#+ do)]] [control ["." exception (#+ exception:)] ["<>" parser ["<.>" code (#+ Parser)]]] + [data + ["." product]] [macro ["." code]]]) @@ -17,6 +20,13 @@ {#type Code #value Code}) +(def: #export equivalence + (Equivalence Check) + ($_ product.equivalence + code.equivalence + code.equivalence + )) + (def: #export (write (^slots [#type #value])) (-> Check Code) (` ((~ (code.text ..extension)) diff --git a/stdlib/source/lux/macro/syntax/common/definition.lux b/stdlib/source/lux/macro/syntax/common/definition.lux new file mode 100644 index 000000000..851fd29b1 --- /dev/null +++ b/stdlib/source/lux/macro/syntax/common/definition.lux @@ -0,0 +1,141 @@ +(.module: + [lux (#- Definition) + ["." meta] + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do)]] + [control + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" code (#+ Parser)]]] + [data + ["." sum] + ["." product] + ["." bit] + ["." name] + ["." text + ["%" format (#+ format)]] + [collection + ["." list]]] + [macro + ["." code]] + [meta + ["." location]]] + ["." // (#+ Annotations) + ["#." check (#+ Check)]]) + +(type: #export Definition + {#name Text + #value (Either Check + Code) + #anns Annotations + #export? Bit}) + +(def: #export equivalence + (Equivalence Definition) + ($_ product.equivalence + text.equivalence + ($_ sum.equivalence + //check.equivalence + code.equivalence + ) + (list.equivalence (product.equivalence name.equivalence + code.equivalence)) + bit.equivalence + )) + +(def: extension + "lux def") + +(def: (write-tag [module short]) + (-> Name Code) + (` [(~ (code.text module)) + (~ (code.text short))])) + +(def: (write-annotations value) + (-> Annotations Code) + (case value + #.Nil + (` #.Nil) + + (#.Cons [name value] tail) + (` (#.Cons [(~ (..write-tag name)) + (~ value)] + (~ (write-annotations tail)))))) + +(def: dummy + Code + (` {#.module (~ (code.text (get@ #.module location.dummy))) + #.line (~ (code.nat (get@ #.line location.dummy))) + #.column (~ (code.nat (get@ #.column location.dummy)))})) + +(def: #export (write (^slots [#name #value #anns #export?])) + (-> Definition Code) + (` ((~ (code.text ..extension)) + (~ (code.local-identifier name)) + (~ (case value + (#.Left check) + (//check.write check) + + (#.Right value) + value)) + [(~ ..dummy) (#.Record (~ (..write-annotations anns)))] + (~ (code.bit export?))))) + +(def: tag-parser + (Parser Name) + (<code>.tuple (<>.and <code>.text <code>.text))) + +(def: annotations-parser + (Parser Annotations) + (<>.rec + (function (_ recur) + ($_ <>.or + (<code>.tag! (name-of #.Nil)) + (<code>.form (do <>.monad + [_ (<code>.tag! (name-of #.Cons)) + [head tail] (<>.and (<code>.tuple (<>.and tag-parser <code>.any)) + recur)] + (wrap [head tail]))) + )))) + +(def: #export (parser compiler) + {#.doc "A reader that first macro-expands and then analyses the input Code, to ensure it's a definition."} + (-> Lux (Parser Definition)) + (do {! <>.monad} + [raw <code>.any + me-raw (|> raw + meta.expand-all + (meta.run compiler) + <>.lift)] + (<| (<code>.local me-raw) + <code>.form + (<>.after (<code>.text! ..extension)) + ($_ <>.and + <code>.local-identifier + (<>.or //check.parser + <code>.any) + (<| <code>.tuple + (<>.after <code>.any) + <code>.form + (<>.after (<code>.this! (` #.Record))) + ..annotations-parser) + <code>.bit + )))) + +(exception: #export (lacks-type! {definition Definition}) + (exception.report + ["Definition" (%.code (..write definition))])) + +(def: #export (typed compiler) + {#.doc "Only works for typed definitions."} + (-> Lux (Parser Definition)) + (do <>.monad + [definition (..parser compiler) + _ (case (get@ #value definition) + (#.Left _) + (wrap []) + + (#.Right _) + (<>.lift (exception.throw ..lacks-type! [definition])))] + (wrap definition))) diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux index 03fea57bc..7033069f6 100644 --- a/stdlib/source/lux/macro/syntax/common/reader.lux +++ b/stdlib/source/lux/macro/syntax/common/reader.lux @@ -12,9 +12,7 @@ [collection ["." list]]] ["." meta]] - ["." // - [/// - [syntax (#+ syntax:)]]]) + ["." //]) (def: #export export (Parser Bit) @@ -37,30 +35,6 @@ (Parser //.Annotations) (s.record (p.some (p.and s.tag s.any)))) -(def: check^ - (Parser [(Maybe Code) Code]) - (p.either (s.form (do p.monad - [_ (s.text! "lux check") - type s.any - value s.any] - (wrap [(#.Some type) value]))) - (p.and (p\wrap #.None) - s.any))) - -(def: _definition-anns-tag^ - (Parser Name) - (s.tuple (p.and s.text s.text))) - -(def: (_definition-anns^ _) - (-> Any (Parser //.Annotations)) - (p.or (s.tag! (name-of #.Nil)) - (s.form (do p.monad - [_ (s.tag! (name-of #.Cons)) - [head tail] (p.and (s.tuple (p.and _definition-anns-tag^ s.any)) - (_definition-anns^ []))] - (wrap [head tail]))) - )) - (def: (flat-list^ _) (-> Any (Parser (List Code))) (p.either (do p.monad @@ -101,43 +75,6 @@ _ #.None))) -(def: #export (definition compiler) - {#.doc "A reader that first macro-expands and then analyses the input Code, to ensure it's a definition."} - (-> Lux (Parser //.Definition)) - (do {! p.monad} - [definition-raw s.any - me-definition-raw (|> definition-raw - meta.expand-all - (meta.run compiler) - p.lift)] - (s.local me-definition-raw - (s.form (do ! - [_ (s.text! "lux def") - definition-name s.local-identifier - [?definition-type definition-value] check^ - definition-anns s.any - definition-anns (s.local (list definition-anns) - (_definition-anns^ [])) - #let [definition-args (find-definition-args definition-anns)]] - (wrap {#//.definition-name definition-name - #//.definition-type ?definition-type - #//.definition-anns definition-anns - #//.definition-value definition-value - #//.definition-args definition-args})))))) - -(def: #export (typed-definition compiler) - {#.doc "A reader for definitions that ensures the input syntax is typed."} - (-> Lux (Parser //.Definition)) - (do p.monad - [_definition (..definition compiler) - _ (case (get@ #//.definition-type _definition) - (#.Some _) - (wrap []) - - #.None - (p.fail "Typed definition must have a type!"))] - (wrap _definition))) - (def: #export typed-input {#.doc "Reader for the common typed-argument syntax used by many macros."} (Parser //.Typed-Input) diff --git a/stdlib/source/lux/math/infix.lux b/stdlib/source/lux/math/infix.lux index 55b82d715..9e9445538 100644 --- a/stdlib/source/lux/math/infix.lux +++ b/stdlib/source/lux/math/infix.lux @@ -1,10 +1,10 @@ (.module: {#.doc "Common mathematical constants and functions."} [lux #* [abstract - monad] + [monad (#+ do)]] [control - ["p" parser ("#\." functor) - ["s" code (#+ Parser)]]] + ["<>" parser ("#\." functor) + ["<.>" code (#+ Parser)]]] [data ["." product] [number @@ -24,45 +24,45 @@ (def: infix^ (Parser Infix) - (<| p.rec (function (_ infix^)) - ($_ p.or - ($_ p.either - (p\map code.bit s.bit) - (p\map code.nat s.nat) - (p\map code.int s.int) - (p\map code.rev s.rev) - (p\map code.frac s.frac) - (p\map code.text s.text) - (p\map code.identifier s.identifier) - (p\map code.tag s.tag)) - (s.form (p.many s.any)) - (s.tuple (p.and s.any infix^)) - (s.tuple ($_ p.either - (do p.monad - [_ (s.this! (' #and)) - init-subject infix^ - init-op s.any - init-param infix^ - steps (p.some (p.and s.any infix^))] - (wrap (product.right (list\fold (function (_ [op param] [subject [_subject _op _param]]) - [param [(#Binary _subject _op _param) - (` and) - (#Binary subject op param)]]) - [init-param [init-subject init-op init-param]] - steps)))) - (do p.monad - [init-subject infix^ - init-op s.any - init-param infix^ - steps (p.some (p.and s.any infix^))] - (wrap (list\fold (function (_ [op param] [_subject _op _param]) - [(#Binary _subject _op _param) op param]) - [init-subject init-op init-param] - steps))) - )) + (<| <>.rec (function (_ infix^)) + ($_ <>.or + ($_ <>.either + (<>\map code.bit <code>.bit) + (<>\map code.nat <code>.nat) + (<>\map code.int <code>.int) + (<>\map code.rev <code>.rev) + (<>\map code.frac <code>.frac) + (<>\map code.text <code>.text) + (<>\map code.identifier <code>.identifier) + (<>\map code.tag <code>.tag)) + (<code>.form (<>.many <code>.any)) + (<code>.tuple (<>.and <code>.any infix^)) + (<code>.tuple ($_ <>.either + (do <>.monad + [_ (<code>.this! (' #and)) + init-subject infix^ + init-op <code>.any + init-param infix^ + steps (<>.some (<>.and <code>.any infix^))] + (wrap (product.right (list\fold (function (_ [op param] [subject [_subject _op _param]]) + [param [(#Binary _subject _op _param) + (` and) + (#Binary subject op param)]]) + [init-param [init-subject init-op init-param]] + steps)))) + (do <>.monad + [init-subject infix^ + init-op <code>.any + init-param infix^ + steps (<>.some (<>.and <code>.any infix^))] + (wrap (list\fold (function (_ [op param] [_subject _op _param]) + [(#Binary _subject _op _param) op param]) + [init-subject init-op init-param] + steps))) + )) ))) -(def: (infix-to-prefix infix) +(def: (to-prefix infix) (-> Infix Code) (case infix (#Const value) @@ -72,10 +72,10 @@ (code.form parts) (#Unary op subject) - (` ((~ op) (~ (infix-to-prefix subject)))) + (` ((~ op) (~ (to-prefix subject)))) (#Binary left op right) - (` ((~ op) (~ (infix-to-prefix right)) (~ (infix-to-prefix left)))) + (` ((~ op) (~ (to-prefix right)) (~ (to-prefix left)))) )) (syntax: #export (infix {expr infix^}) @@ -91,4 +91,4 @@ "If you want your binary function to work well with it." "Then take the argument to the right (y) as your first argument," "and take the argument to the left (x) as your second argument.")} - (wrap (list (infix-to-prefix expr)))) + (wrap (list (..to-prefix expr)))) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index e1f34cd32..aa13297c4 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -174,7 +174,7 @@ (-> Nat (Random Text)) (..text (..char <set>)))] - [unicode unicode.full] + [unicode unicode.character] [ascii unicode.ascii] [ascii/alpha unicode.ascii/alpha] [ascii/alpha-num unicode.ascii/alpha-num] diff --git a/stdlib/source/program/aedifex.lux b/stdlib/source/program/aedifex.lux index 41d7f9b2f..cfa106407 100644 --- a/stdlib/source/program/aedifex.lux +++ b/stdlib/source/program/aedifex.lux @@ -82,18 +82,27 @@ (format (%.text name) " := " (%.text repo))) (dictionary.entries options))])) +(def: succeed! + (IO Any) + (\ program.default exit shell.normal)) + +(def: (fail! error) + (-> Text (IO Any)) + (exec + (log! error) + (\ program.default exit shell.error))) + (def: (command action) (All [a] (-> (Promise (Try a)) (IO Any))) (exec (do promise.monad - [outcome action - #let [code (case outcome - (#try.Failure error) - (exec (log! error) - shell.normal) - - (#try.Success _) - shell.error)]] - (promise.future (\ program.default exit code))) + [outcome action] + (promise.future + (case outcome + (#try.Success _) + ..succeed! + + (#try.Failure error) + (..fail! error)))) (\ io.monad wrap []))) (program: [{[profile operation] /cli.command}] @@ -101,7 +110,7 @@ [?console console.default] (case (try\map console.async ?console) (#try.Failure error) - (wrap (log! error)) + (..fail! error) (#try.Success console) (case operation @@ -114,8 +123,7 @@ [?profile (/input.read io.monad file.default profile)] (case ?profile (#try.Failure error) - (exec (log! error) - (\ program.default exit shell.error)) + (..fail! error) (#try.Success profile) (let [program (program.async program.default)] @@ -169,7 +177,7 @@ [?watcher watch.default] (case ?watcher (#try.Failure error) - (wrap (log! error)) + (..fail! error) (#try.Success watcher) (..command diff --git a/stdlib/source/program/aedifex/dependency/status.lux b/stdlib/source/program/aedifex/dependency/status.lux new file mode 100644 index 000000000..fa62f643e --- /dev/null +++ b/stdlib/source/program/aedifex/dependency/status.lux @@ -0,0 +1,35 @@ +(.module: + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." sum] + ["." product]]] + ["." /// #_ + ["#." hash (#+ Hash SHA-1 MD5)]]) + +(type: #export Status + #Unverified + (#Partial (Either (Hash SHA-1) + (Hash MD5))) + (#Verified (Hash SHA-1) (Hash MD5))) + +(structure: any-equivalence + (Equivalence Any) + + (def: (= _ _) + true)) + +(def: #export equivalence + (Equivalence Status) + ($_ sum.equivalence + ..any-equivalence + ($_ sum.equivalence + ///hash.equivalence + ///hash.equivalence + ) + ($_ product.equivalence + ///hash.equivalence + ///hash.equivalence + ) + )) diff --git a/stdlib/source/spec/aedifex/repository.lux b/stdlib/source/spec/aedifex/repository.lux index 77c453f4b..acea123bc 100644 --- a/stdlib/source/spec/aedifex/repository.lux +++ b/stdlib/source/spec/aedifex/repository.lux @@ -28,11 +28,13 @@ [expected (_binary.random 100)] (wrap ($_ _.and' (do promise.monad - [upload!/good (\ subject upload valid-identity valid-artifact //artifact/extension.lux-library expected) - download!/good (\ subject download valid-artifact //artifact/extension.lux-library) + [#let [uri/good (/.uri valid-artifact //artifact/extension.lux-library)] + upload!/good (\ subject upload valid-identity uri/good expected) + download!/good (\ subject download uri/good) - upload!/bad (\ subject upload invalid-identity invalid-artifact //artifact/extension.lux-library expected) - download!/bad (\ subject download invalid-artifact //artifact/extension.lux-library)] + #let [uri/bad (/.uri invalid-artifact //artifact/extension.lux-library)] + upload!/bad (\ subject upload invalid-identity uri/bad expected) + download!/bad (\ subject download uri/bad)] (_.cover' [/.Repository] (and (case [upload!/good download!/good] [(#try.Success _) (#try.Success actual)] diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux index 2f46df228..eebccdf09 100644 --- a/stdlib/source/test/aedifex.lux +++ b/stdlib/source/test/aedifex.lux @@ -21,7 +21,8 @@ ["#." local] ["#." cache] ["#." dependency - ["#/." resolution]] + ["#/." resolution] + ["#/." status]] ["#." package] ["#." profile] ["#." project] @@ -51,6 +52,7 @@ /cache.test /dependency.test /dependency/resolution.test + /dependency/status.test /package.test /profile.test /project.test diff --git a/stdlib/source/test/aedifex/command/deploy.lux b/stdlib/source/test/aedifex/command/deploy.lux index ef08ba39e..18045a20b 100644 --- a/stdlib/source/test/aedifex/command/deploy.lux +++ b/stdlib/source/test/aedifex/command/deploy.lux @@ -110,11 +110,11 @@ set.to-list (export.library fs) (\ ! map (format.run tar.writer))) - - actual-pom (\ repository download artifact ///artifact/extension.pom) - actual-library (\ repository download artifact ///artifact/extension.lux-library) - actual-sha-1 (\ repository download artifact ///artifact/extension.sha-1) - actual-md5 (\ repository download artifact ///artifact/extension.md5) + + actual-pom (\ repository download (///repository.uri artifact ///artifact/extension.pom)) + actual-library (\ repository download (///repository.uri artifact ///artifact/extension.lux-library)) + actual-sha-1 (\ repository download (///repository.uri artifact (format ///artifact/extension.lux-library ///artifact/extension.sha-1))) + actual-md5 (\ repository download (///repository.uri artifact (format ///artifact/extension.lux-library ///artifact/extension.md5))) #let [deployed-library! (\ binary.equivalence = diff --git a/stdlib/source/test/aedifex/dependency/status.lux b/stdlib/source/test/aedifex/dependency/status.lux new file mode 100644 index 000000000..90cc547fa --- /dev/null +++ b/stdlib/source/test/aedifex/dependency/status.lux @@ -0,0 +1,34 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + {[0 #spec] + [/ + ["$." equivalence]]}] + [math + ["." random (#+ Random) ("#\." monad)]]] + ["$." /// #_ + ["#." hash]] + {#program + ["." / + ["//#" /// #_ + ["#." hash]]]}) + +(def: #export random + (Random /.Status) + ($_ random.or + (random\wrap []) + (random.or ($///hash.random ///hash.sha-1) + ($///hash.random ///hash.md5)) + (random.and ($///hash.random ///hash.sha-1) + ($///hash.random ///hash.md5)) + )) + +(def: #export test + Test + (<| (_.covering /._) + (_.for [/.Status] + ($_ _.and + (_.for [/.equivalence] + ($equivalence.spec /.equivalence ..random)) + )))) diff --git a/stdlib/source/test/aedifex/hash.lux b/stdlib/source/test/aedifex/hash.lux index 8bc830801..455835b84 100644 --- a/stdlib/source/test/aedifex/hash.lux +++ b/stdlib/source/test/aedifex/hash.lux @@ -25,7 +25,7 @@ [data ["_." binary]]]]) -(def: (random hash) +(def: #export (random hash) (All [h] (-> (-> Binary (/.Hash h)) (Random (/.Hash h)))) diff --git a/stdlib/source/test/aedifex/metadata.lux b/stdlib/source/test/aedifex/metadata.lux index 6a1ac503a..9dd3fac22 100644 --- a/stdlib/source/test/aedifex/metadata.lux +++ b/stdlib/source/test/aedifex/metadata.lux @@ -23,10 +23,10 @@ (do random.monad [sample @artifact.random] ($_ _.and - (_.cover [/.for-project] - (text.ends-with? /.file (/.for-project sample))) - (_.cover [/.for-version] - (text.ends-with? /.file (/.for-version sample))) + (_.cover [/.project] + (text.ends-with? /.file (/.project sample))) + (_.cover [/.version] + (text.ends-with? /.file (/.version sample))) ))) /artifact.test diff --git a/stdlib/source/test/aedifex/repository.lux b/stdlib/source/test/aedifex/repository.lux index ff669d687..5d2b62f57 100644 --- a/stdlib/source/test/aedifex/repository.lux +++ b/stdlib/source/test/aedifex/repository.lux @@ -17,7 +17,10 @@ [collection ["." dictionary (#+ Dictionary)]]] [math - ["." random (#+ Random)]]] + ["." random (#+ Random)]] + [world + [net + ["." uri (#+ URI)]]]] [// ["@." artifact]] {#spec @@ -42,41 +45,34 @@ (-> Version Artifact) (|>> ["com.github.luxlang" "test-artifact"])) -(def: item-hash - (Hash [Artifact Extension]) - (product.hash //artifact.hash - text.hash)) - -(exception: (not-found {artifact Artifact} - {extension Extension}) +(exception: (not-found {uri URI}) (exception.report - ["Artifact" (//artifact.format artifact)] - ["Extension" (%.text extension)])) + ["URI" (%.text uri)])) (exception: (invalid-identity {[user _] Identity}) (exception.report ["User" (%.text user)])) (type: Store - (Dictionary [Artifact Extension] Binary)) + (Dictionary URI Binary)) (def: #export empty Store - (dictionary.new ..item-hash)) + (dictionary.new text.hash)) (structure: #export (simulation identity) (-> Identity (/.Simulation Store)) - (def: (on-download artifact extension state) - (case (dictionary.get [artifact extension] state) + (def: (on-download uri state) + (case (dictionary.get uri state) (#.Some content) (exception.return [state content]) #.None - (exception.throw ..not-found [artifact extension]))) - (def: (on-upload requester artifact extension content state) + (exception.throw ..not-found [uri]))) + (def: (on-upload requester uri content state) (if (\ identity-equivalence = identity requester) - (exception.return (dictionary.put [artifact extension] content state)) + (exception.return (dictionary.put uri content state)) (exception.throw ..invalid-identity [requester])))) (def: #export test diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index 37ae36572..faf08f9b8 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -13,10 +13,7 @@ ["#/." stm]] ["#." continuation] ["#." exception] - ["#." function - ["#/." contract] - ["#/." memo] - ["#/." mixin]] + ["#." function] ["#." io] ["#." parser] ["#." pipe] @@ -43,15 +40,6 @@ /concurrency/stm.test )) -(def: function - Test - ($_ _.and - /function.test - /function/contract.test - /function/memo.test - /function/mixin.test - )) - (def: security Test ($_ _.and @@ -66,7 +54,7 @@ ..concurrency /continuation.test /exception.test - ..function + /function.test /io.test /parser.test /pipe.test diff --git a/stdlib/source/test/lux/control/function.lux b/stdlib/source/test/lux/control/function.lux index 3bd59dc41..c78d4f2e5 100644 --- a/stdlib/source/test/lux/control/function.lux +++ b/stdlib/source/test/lux/control/function.lux @@ -14,7 +14,11 @@ ["." random (#+ Random)]] ["_" test (#+ Test)]] {1 - ["." /]}) + ["." /]} + ["." / #_ + ["#." contract] + ["#." memo] + ["#." mixin]]) (def: #export test Test @@ -54,4 +58,8 @@ (_.cover [/.apply] (n.= (f0 extra) (/.apply extra f0))) + + /contract.test + /memo.test + /mixin.test )))) diff --git a/stdlib/source/test/lux/control/function/memo.lux b/stdlib/source/test/lux/control/function/memo.lux index 0180196b2..88be05a17 100644 --- a/stdlib/source/test/lux/control/function/memo.lux +++ b/stdlib/source/test/lux/control/function/memo.lux @@ -50,7 +50,7 @@ Test (<| (_.covering /._) (do {! random.monad} - [input (|> random.nat (\ ! map (|>> (n.% 5) (n.+ 23))))]) + [input (|> random.nat (\ ! map (|>> (n.% 5) (n.+ 20))))]) (_.for [/.Memo]) ($_ _.and (_.cover [/.closed /.none] @@ -72,13 +72,24 @@ open (/.open fibonacci)] [none-time none-output] (..time none input) [open-time [memory open-output]] (..time open [memory input]) - [open-time/+1 _] (..time open [memory (inc input)])] - (wrap (and (n.= none-output - open-output) - (n.< (milli-seconds none-time) - (milli-seconds open-time)) - (n.< (milli-seconds open-time) - (milli-seconds open-time/+1))))))) + [open-time/+1 _] (..time open [memory (inc input)]) + #let [same-output! + (n.= none-output + open-output) + + memo-is-faster! + (n.< (milli-seconds none-time) + (milli-seconds open-time)) + + incrementalism-is-faster! + ## the wiggle room is there to account for GC pauses + ## and other issues that might mess with duration + (let [wiggle-room 2] + (n.< (n.+ wiggle-room (milli-seconds open-time)) + (milli-seconds open-time/+1)))]] + (wrap (and same-output! + memo-is-faster! + incrementalism-is-faster!))))) (_.cover [/.memoization] (let [memo (<| //.mixin (//.inherit /.memoization) diff --git a/stdlib/source/test/lux/control/parser/text.lux b/stdlib/source/test/lux/control/parser/text.lux index dd5f4d6a8..486fc8798 100644 --- a/stdlib/source/test/lux/control/parser/text.lux +++ b/stdlib/source/test/lux/control/parser/text.lux @@ -13,7 +13,7 @@ ["%" format (#+ format)] ["." unicode #_ ["#" set] - ["#/." segment]]] + ["#/." block]]] [number ["n" nat]] [collection @@ -83,52 +83,52 @@ (..should-fail out-of-range (/.range offset limit))))) (do {! random.monad} [expected (random.char unicode.ascii/upper-alpha) - invalid (random.filter (|>> (unicode/segment.within? unicode/segment.basic-latin/upper-alpha) not) - (random.char unicode.full))] + invalid (random.filter (|>> (unicode/block.within? unicode/block.basic-latin/upper-alpha) not) + (random.char unicode.character))] (_.cover [/.upper] (and (..should-pass (text.from-code expected) /.upper) (..should-fail (text.from-code invalid) /.upper)))) (do {! random.monad} [expected (random.char unicode.ascii/lower-alpha) - invalid (random.filter (|>> (unicode/segment.within? unicode/segment.basic-latin/lower-alpha) not) - (random.char unicode.full))] + invalid (random.filter (|>> (unicode/block.within? unicode/block.basic-latin/lower-alpha) not) + (random.char unicode.character))] (_.cover [/.lower] (and (..should-pass (text.from-code expected) /.lower) (..should-fail (text.from-code invalid) /.lower)))) (do {! random.monad} [expected (\ ! map (n.% 10) random.nat) - invalid (random.char (unicode.set [unicode/segment.number-forms (list)]))] + invalid (random.char (unicode.set [unicode/block.number-forms (list)]))] (_.cover [/.decimal] (and (..should-pass (\ n.decimal encode expected) /.decimal) (..should-fail (text.from-code invalid) /.decimal)))) (do {! random.monad} [expected (\ ! map (n.% 8) random.nat) - invalid (random.char (unicode.set [unicode/segment.number-forms (list)]))] + invalid (random.char (unicode.set [unicode/block.number-forms (list)]))] (_.cover [/.octal] (and (..should-pass (\ n.octal encode expected) /.octal) (..should-fail (text.from-code invalid) /.octal)))) (do {! random.monad} [expected (\ ! map (n.% 16) random.nat) - invalid (random.char (unicode.set [unicode/segment.number-forms (list)]))] + invalid (random.char (unicode.set [unicode/block.number-forms (list)]))] (_.cover [/.hexadecimal] (and (..should-pass (\ n.hex encode expected) /.hexadecimal) (..should-fail (text.from-code invalid) /.hexadecimal)))) (do {! random.monad} [expected (random.char unicode.ascii/alpha) invalid (random.filter (function (_ char) - (not (or (unicode/segment.within? unicode/segment.basic-latin/upper-alpha char) - (unicode/segment.within? unicode/segment.basic-latin/lower-alpha char)))) - (random.char unicode.full))] + (not (or (unicode/block.within? unicode/block.basic-latin/upper-alpha char) + (unicode/block.within? unicode/block.basic-latin/lower-alpha char)))) + (random.char unicode.character))] (_.cover [/.alpha] (and (..should-pass (text.from-code expected) /.alpha) (..should-fail (text.from-code invalid) /.alpha)))) (do {! random.monad} [expected (random.char unicode.ascii/alpha-num) invalid (random.filter (function (_ char) - (not (or (unicode/segment.within? unicode/segment.basic-latin/upper-alpha char) - (unicode/segment.within? unicode/segment.basic-latin/lower-alpha char) - (unicode/segment.within? unicode/segment.basic-latin/decimal char)))) - (random.char unicode.full))] + (not (or (unicode/block.within? unicode/block.basic-latin/upper-alpha char) + (unicode/block.within? unicode/block.basic-latin/lower-alpha char) + (unicode/block.within? unicode/block.basic-latin/decimal char)))) + (random.char unicode.character))] (_.cover [/.alpha-num] (and (..should-pass (text.from-code expected) /.alpha-num) (..should-fail (text.from-code invalid) /.alpha-num)))) @@ -152,11 +152,12 @@ (..should-fail invalid /.space)))) (do {! random.monad} [#let [num-options 3] - options (|> (random.char unicode.full) - (random.set n.hash num-options) - (\ ! map (|>> set.to-list - (list\map text.from-code) - (text.join-with "")))) + chars (random.set n.hash num-options + (random.char unicode.character)) + #let [options (|> chars + set.to-list + (list\map text.from-code) + (text.join-with ""))] expected (\ ! map (function (_ value) (|> options (text.nth (n.% num-options value)) @@ -165,7 +166,7 @@ invalid (random.filter (|>> text.from-code (text.contains? options) not) - (random.char unicode.full))] + (random.char unicode.character))] (_.cover [/.one-of /.one-of! /.character-should-be] (and (..should-pass (text.from-code expected) (/.one-of options)) (..should-fail (text.from-code invalid) (/.one-of options)) @@ -175,10 +176,11 @@ (..should-pass! (text.from-code expected) (/.one-of! options)) (..should-fail (text.from-code invalid) (/.one-of! options)) (..should-fail' (text.from-code invalid) (/.one-of! options) - /.character-should-be)))) + /.character-should-be) + ))) (do {! random.monad} [#let [num-options 3] - options (|> (random.char unicode.full) + options (|> (random.char unicode.character) (random.set n.hash num-options) (\ ! map (|>> set.to-list (list\map text.from-code) @@ -191,7 +193,7 @@ expected (random.filter (|>> text.from-code (text.contains? options) not) - (random.char unicode.full))] + (random.char unicode.character))] (_.cover [/.none-of /.none-of! /.character-should-not-be] (and (..should-pass (text.from-code expected) (/.none-of options)) (..should-fail (text.from-code invalid) (/.none-of options)) @@ -396,9 +398,9 @@ (text\= expected actual)))))) (do {! random.monad} [invalid (random.ascii/upper-alpha 1) - expected (random.filter (|>> (unicode/segment.within? unicode/segment.basic-latin/upper-alpha) + expected (random.filter (|>> (unicode/block.within? unicode/block.basic-latin/upper-alpha) not) - (random.char unicode.full)) + (random.char unicode.character)) #let [upper! (/.one-of! "ABCDEFGHIJKLMNOPQRSTUVWXYZ")]] (_.cover [/.not /.not! /.expected-to-fail] (and (..should-pass (text.from-code expected) (/.not /.upper)) @@ -416,9 +418,9 @@ [upper (random.ascii/upper-alpha 1) lower (random.ascii/lower-alpha 1) invalid (random.filter (function (_ char) - (not (or (unicode/segment.within? unicode/segment.basic-latin/upper-alpha char) - (unicode/segment.within? unicode/segment.basic-latin/lower-alpha char)))) - (random.char unicode.full)) + (not (or (unicode/block.within? unicode/block.basic-latin/upper-alpha char) + (unicode/block.within? unicode/block.basic-latin/lower-alpha char)))) + (random.char unicode.character)) #let [upper! (/.one-of! "ABCDEFGHIJKLMNOPQRSTUVWXYZ") lower! (/.one-of! "abcdefghijklmnopqrstuvwxyz")]] (_.cover [/.and /.and!] diff --git a/stdlib/source/test/lux/data/format/tar.lux b/stdlib/source/test/lux/data/format/tar.lux index 92f5915c7..7f271de05 100644 --- a/stdlib/source/test/lux/data/format/tar.lux +++ b/stdlib/source/test/lux/data/format/tar.lux @@ -17,7 +17,7 @@ ["." encoding] ["." unicode #_ ["#" set] - ["#/." segment]]] + ["#/." block]]] [number ["n" nat] ["i" int]] @@ -40,7 +40,7 @@ (do {! random.monad} [expected (random.ascii/lower-alpha /.path-size) invalid (random.ascii/lower-alpha (inc /.path-size)) - not-ascii (random.text (random.char (unicode.set [unicode/segment.katakana (list)])) + not-ascii (random.text (random.char (unicode.set [unicode/block.katakana (list)])) /.path-size)] (`` ($_ _.and (_.cover [/.path /.from-path] @@ -73,7 +73,7 @@ (do {! random.monad} [expected (random.ascii/lower-alpha /.name-size) invalid (random.ascii/lower-alpha (inc /.name-size)) - not-ascii (random.text (random.char (unicode.set [unicode/segment.katakana (list)])) + not-ascii (random.text (random.char (unicode.set [unicode/block.katakana (list)])) /.name-size)] (`` ($_ _.and (_.cover [/.name /.from-name] @@ -314,7 +314,7 @@ [path (random.ascii/lower-alpha /.path-size) expected (random.ascii/lower-alpha /.name-size) invalid (random.ascii/lower-alpha (inc /.name-size)) - not-ascii (random.text (random.char (unicode.set [unicode/segment.katakana (list)])) + not-ascii (random.text (random.char (unicode.set [unicode/block.katakana (list)])) /.name-size)] (_.for [/.Ownership /.Owner /.ID] ($_ _.and diff --git a/stdlib/source/test/lux/data/text/unicode/block.lux b/stdlib/source/test/lux/data/text/unicode/block.lux new file mode 100644 index 000000000..eb55617ca --- /dev/null +++ b/stdlib/source/test/lux/data/text/unicode/block.lux @@ -0,0 +1,211 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + {[0 #spec] + [/ + ["$." equivalence] + ["$." hash] + ["$." monoid]]}] + [data + ["." text] + [number (#+ hex) + ["n" nat]] + [collection + ["." set] + ["." list]]] + [macro + ["." template]] + [math + ["." random (#+ Random)]]] + {1 + ["." /]}) + +(def: #export random + (Random /.Block) + (do random.monad + [start random.nat + end random.nat] + (wrap (/.block start end)))) + +(with-expansions [<blocks> (as-is [blocks/0 + [/.basic-latin + /.latin-1-supplement + /.latin-extended-a + /.latin-extended-b + /.ipa-extensions + /.spacing-modifier-letters + /.combining-diacritical-marks + /.greek-and-coptic + /.cyrillic + /.cyrillic-supplementary + /.armenian + /.hebrew + /.arabic + /.syriac + /.thaana + /.devanagari + /.bengali + /.gurmukhi + /.gujarati + /.oriya + /.tamil + /.telugu + /.kannada + /.malayalam + /.sinhala + /.thai + /.lao + /.tibetan + /.myanmar + /.georgian + /.hangul-jamo + /.ethiopic + /.cherokee + /.unified-canadian-aboriginal-syllabics + /.ogham + /.runic + /.tagalog + /.hanunoo + /.buhid + /.tagbanwa + /.khmer + /.mongolian]] + [blocks/1 + [/.limbu + /.tai-le + /.khmer-symbols + /.phonetic-extensions + /.latin-extended-additional + /.greek-extended + /.general-punctuation + /.superscripts-and-subscripts + /.currency-symbols + /.combining-diacritical-marks-for-symbols + /.letterlike-symbols + /.number-forms + /.arrows + /.mathematical-operators + /.miscellaneous-technical + /.control-pictures + /.optical-character-recognition + /.enclosed-alphanumerics + /.box-drawing + /.block-elements + /.geometric-shapes + /.miscellaneous-symbols + /.dingbats + /.miscellaneous-mathematical-symbols-a + /.supplemental-arrows-a + /.braille-patterns + /.supplemental-arrows-b + /.miscellaneous-mathematical-symbols-b + /.supplemental-mathematical-operators + /.miscellaneous-symbols-and-arrows + /.cjk-radicals-supplement + /.kangxi-radicals + /.ideographic-description-characters + /.cjk-symbols-and-punctuation + /.hiragana + /.katakana + /.bopomofo + /.hangul-compatibility-jamo + /.kanbun + /.bopomofo-extended + /.katakana-phonetic-extensions + /.enclosed-cjk-letters-and-months + /.cjk-compatibility + /.cjk-unified-ideographs-extension-a + /.yijing-hexagram-symbols + /.cjk-unified-ideographs + /.yi-syllables + /.yi-radicals + /.hangul-syllables + /.high-surrogates + /.high-private-use-surrogates + /.low-surrogates + /.private-use-area + /.cjk-compatibility-ideographs + /.alphabetic-presentation-forms]] + [blocks/2 + [/.arabic-presentation-forms-a + /.variation-selectors + /.combining-half-marks + /.cjk-compatibility-forms + /.small-form-variants + /.arabic-presentation-forms-b + /.halfwidth-and-fullwidth-forms + /.specials + + ## Specialized blocks + /.basic-latin/decimal + /.basic-latin/upper-alpha + /.basic-latin/lower-alpha]] + ) + <named> (template [<definition> <part>] + [((: (-> Any (List /.Block)) + (function (_ _) + (`` (list (~~ (template.splice <part>)))))) + [])] + + <blocks>)] + (template [<definition> <part>] + [(def: <definition> + Test + (`` (_.cover [(~~ (template.splice <part>))] + (let [all (list.concat (list <named>)) + unique (set.from-list /.hash all)] + (n.= (list.size all) + (set.size unique))))))] + + <blocks> + ) + + (def: #export test + Test + (<| (_.covering /._) + (_.for [/.Block]) + (do {! random.monad} + [#let [top-start (hex "AC00") + top-end (hex "D7AF")] + start (\ ! map (|>> (n.% top-start) inc) random.nat) + end (\ ! map (|>> (n.% top-end) inc) random.nat) + #let [sample (/.block start end) + size (/.size sample)] + inside (\ ! map + (|>> (n.% size) + (n.+ (/.start sample))) + random.nat)] + (`` ($_ _.and + (_.for [/.equivalence] + ($equivalence.spec /.equivalence ..random)) + (_.for [/.hash] + ($hash.spec /.hash ..random)) + (_.for [/.monoid] + ($monoid.spec /.equivalence /.monoid ..random)) + + (_.cover [/.block] + (\ /.equivalence = + (/.block start end) + (/.block end start))) + (_.cover [/.start] + (n.= (n.min start end) + (/.start (/.block start end)))) + (_.cover [/.end] + (n.= (n.max start end) + (/.end (/.block start end)))) + (_.cover [/.size] + (n.= (inc (n.- (n.min start end) + (n.max start end))) + (/.size (/.block start end)))) + (_.cover [/.within?] + (and (/.within? sample inside) + (not (/.within? sample (dec (/.start sample)))) + (not (/.within? sample (inc (/.end sample)))))) + (~~ (template [<definition> <part>] + [<definition>] + + <blocks>)) + ))))) + ) diff --git a/stdlib/source/test/lux/data/text/unicode/segment.lux b/stdlib/source/test/lux/data/text/unicode/segment.lux deleted file mode 100644 index 62a399cd1..000000000 --- a/stdlib/source/test/lux/data/text/unicode/segment.lux +++ /dev/null @@ -1,211 +0,0 @@ -(.module: - [lux #* - ["_" test (#+ Test)] - [abstract - [monad (#+ do)] - {[0 #spec] - [/ - ["$." equivalence] - ["$." hash] - ["$." monoid]]}] - [data - ["." text] - [number (#+ hex) - ["n" nat]] - [collection - ["." set] - ["." list]]] - [macro - ["." template]] - [math - ["." random (#+ Random)]]] - {1 - ["." /]}) - -(def: #export random - (Random /.Segment) - (do random.monad - [start random.nat - end random.nat] - (wrap (/.segment start end)))) - -(with-expansions [<segments> (as-is [segments/0 - [/.basic-latin - /.latin-1-supplement - /.latin-extended-a - /.latin-extended-b - /.ipa-extensions - /.spacing-modifier-letters - /.combining-diacritical-marks - /.greek-and-coptic - /.cyrillic - /.cyrillic-supplementary - /.armenian - /.hebrew - /.arabic - /.syriac - /.thaana - /.devanagari - /.bengali - /.gurmukhi - /.gujarati - /.oriya - /.tamil - /.telugu - /.kannada - /.malayalam - /.sinhala - /.thai - /.lao - /.tibetan - /.myanmar - /.georgian - /.hangul-jamo - /.ethiopic - /.cherokee - /.unified-canadian-aboriginal-syllabics - /.ogham - /.runic - /.tagalog - /.hanunoo - /.buhid - /.tagbanwa - /.khmer - /.mongolian]] - [segments/1 - [/.limbu - /.tai-le - /.khmer-symbols - /.phonetic-extensions - /.latin-extended-additional - /.greek-extended - /.general-punctuation - /.superscripts-and-subscripts - /.currency-symbols - /.combining-diacritical-marks-for-symbols - /.letterlike-symbols - /.number-forms - /.arrows - /.mathematical-operators - /.miscellaneous-technical - /.control-pictures - /.optical-character-recognition - /.enclosed-alphanumerics - /.box-drawing - /.block-elements - /.geometric-shapes - /.miscellaneous-symbols - /.dingbats - /.miscellaneous-mathematical-symbols-a - /.supplemental-arrows-a - /.braille-patterns - /.supplemental-arrows-b - /.miscellaneous-mathematical-symbols-b - /.supplemental-mathematical-operators - /.miscellaneous-symbols-and-arrows - /.cjk-radicals-supplement - /.kangxi-radicals - /.ideographic-description-characters - /.cjk-symbols-and-punctuation - /.hiragana - /.katakana - /.bopomofo - /.hangul-compatibility-jamo - /.kanbun - /.bopomofo-extended - /.katakana-phonetic-extensions - /.enclosed-cjk-letters-and-months - /.cjk-compatibility - /.cjk-unified-ideographs-extension-a - /.yijing-hexagram-symbols - /.cjk-unified-ideographs - /.yi-syllables - /.yi-radicals - /.hangul-syllables - /.high-surrogates - /.high-private-use-surrogates - /.low-surrogates - /.private-use-area - /.cjk-compatibility-ideographs - /.alphabetic-presentation-forms]] - [segments/2 - [/.arabic-presentation-forms-a - /.variation-selectors - /.combining-half-marks - /.cjk-compatibility-forms - /.small-form-variants - /.arabic-presentation-forms-b - /.halfwidth-and-fullwidth-forms - /.specials - - ## Specialized segments - /.basic-latin/decimal - /.basic-latin/upper-alpha - /.basic-latin/lower-alpha]] - ) - <named> (template [<definition> <part>] - [((: (-> Any (List /.Segment)) - (function (_ _) - (`` (list (~~ (template.splice <part>)))))) - [])] - - <segments>)] - (template [<definition> <part>] - [(def: <definition> - Test - (`` (_.cover [(~~ (template.splice <part>))] - (let [all (list.concat (list <named>)) - unique (set.from-list /.hash all)] - (n.= (list.size all) - (set.size unique))))))] - - <segments> - ) - - (def: #export test - Test - (<| (_.covering /._) - (_.for [/.Segment]) - (do {! random.monad} - [#let [top-start (hex "AC00") - top-end (hex "D7AF")] - start (\ ! map (|>> (n.% top-start) inc) random.nat) - end (\ ! map (|>> (n.% top-end) inc) random.nat) - #let [sample (/.segment start end) - size (/.size sample)] - inside (\ ! map - (|>> (n.% size) - (n.+ (/.start sample))) - random.nat)] - (`` ($_ _.and - (_.for [/.equivalence] - ($equivalence.spec /.equivalence ..random)) - (_.for [/.hash] - ($hash.spec /.hash ..random)) - (_.for [/.monoid] - ($monoid.spec /.equivalence /.monoid ..random)) - - (_.cover [/.segment] - (\ /.equivalence = - (/.segment start end) - (/.segment end start))) - (_.cover [/.start] - (n.= (n.min start end) - (/.start (/.segment start end)))) - (_.cover [/.end] - (n.= (n.max start end) - (/.end (/.segment start end)))) - (_.cover [/.size] - (n.= (inc (n.- (n.min start end) - (n.max start end))) - (/.size (/.segment start end)))) - (_.cover [/.within?] - (and (/.within? sample inside) - (not (/.within? sample (dec (/.start sample)))) - (not (/.within? sample (inc (/.end sample)))))) - (~~ (template [<definition> <part>] - [<definition>] - - <segments>)) - ))))) - ) diff --git a/stdlib/source/test/lux/data/text/unicode/set.lux b/stdlib/source/test/lux/data/text/unicode/set.lux index 21c5a90f1..16e29d368 100644 --- a/stdlib/source/test/lux/data/text/unicode/set.lux +++ b/stdlib/source/test/lux/data/text/unicode/set.lux @@ -17,17 +17,17 @@ ["." random (#+ Random)]]] ["." / #_ ["/#" // #_ - ["#." segment]]] + ["#." block]]] {1 ["." / [// - ["." segment]]]}) + ["." block]]]}) (def: #export random (Random /.Set) (do {! random.monad} - [left //segment.random - right //segment.random] + [left //block.random + right //block.random] (wrap (/.set [left (list right)])))) (def: #export test @@ -35,13 +35,13 @@ (<| (_.covering /._) (_.for [/.Set]) (do {! random.monad} - [segment //segment.random + [block //block.random inside (\ ! map - (|>> (n.% (segment.size segment)) - (n.+ (segment.start segment))) + (|>> (n.% (block.size block)) + (n.+ (block.start block))) random.nat) - left //segment.random - right //segment.random + left //block.random + right //block.random #let [equivalence (product.equivalence n.equivalence n.equivalence)]] (`` ($_ _.and @@ -50,21 +50,21 @@ (_.cover [/.range] (let [[start end] (/.range (/.set [left (list right)]))] - (and (n.= (n.min (segment.start left) - (segment.start right)) + (and (n.= (n.min (block.start left) + (block.start right)) start) - (n.= (n.max (segment.end left) - (segment.end right)) + (n.= (n.max (block.end left) + (block.end right)) end)))) (_.cover [/.member?] - (bit\= (segment.within? segment inside) - (/.member? (/.set [segment (list)]) inside))) + (bit\= (block.within? block inside) + (/.member? (/.set [block (list)]) inside))) (_.cover [/.compose] (\ equivalence = - [(n.min (segment.start left) - (segment.start right)) - (n.max (segment.end left) - (segment.end right))] + [(n.min (block.start left) + (block.start right)) + (n.max (block.end left) + (block.end right))] (/.range (/.compose (/.set [left (list)]) (/.set [right (list)]))))) (_.cover [/.set] @@ -86,8 +86,10 @@ [/.ascii/alpha-num] [/.ascii/lower-alpha] [/.ascii/upper-alpha] + [/.character] + [/.non-character] [/.full] )) - //segment.test + //block.test ))))) diff --git a/stdlib/source/test/lux/macro/syntax/common.lux b/stdlib/source/test/lux/macro/syntax/common.lux index 9fcb10006..98b3cdc0c 100644 --- a/stdlib/source/test/lux/macro/syntax/common.lux +++ b/stdlib/source/test/lux/macro/syntax/common.lux @@ -29,7 +29,8 @@ ["." /// #_ ["#." code]] ["." / #_ - ["#." check]]) + ["#." check] + ["#." definition]]) (def: annotations-equivalence (Equivalence /.Annotations) @@ -136,4 +137,5 @@ false)))) /check.test + /definition.test ))) diff --git a/stdlib/source/test/lux/macro/syntax/common/check.lux b/stdlib/source/test/lux/macro/syntax/common/check.lux index 63d042620..6b4a4ab3d 100644 --- a/stdlib/source/test/lux/macro/syntax/common/check.lux +++ b/stdlib/source/test/lux/macro/syntax/common/check.lux @@ -2,7 +2,10 @@ [lux #* ["_" test (#+ Test)] [abstract - [monad (#+ do)]] + [monad (#+ do)] + {[0 #spec] + [/ + ["$." equivalence]]}] [control ["." try] ["<>" parser @@ -16,20 +19,30 @@ ["$." //// #_ ["#." code]]) +(def: #export random + (Random /.Check) + ($_ random.and + $////code.random + $////code.random + )) + (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)))))))) + ($_ _.and + (_.for [/.equivalence] + ($equivalence.spec /.equivalence ..random)) + + (do random.monad + [[type value] ..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))))))))) diff --git a/stdlib/source/test/lux/macro/syntax/common/definition.lux b/stdlib/source/test/lux/macro/syntax/common/definition.lux new file mode 100644 index 000000000..4e3352e40 --- /dev/null +++ b/stdlib/source/test/lux/macro/syntax/common/definition.lux @@ -0,0 +1,103 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + {[0 #spec] + [/ + ["$." equivalence]]}] + [control + ["." try] + ["." exception] + ["<>" parser + ["<.>" code]]] + [math + ["." random (#+ Random)]] + [macro + ["." code ("#\." equivalence)]] + [meta + ["." location]]] + {1 + ["." / + [// (#+ Annotations)]]} + ["$."// #_ + ["#." check] + ["#//" /// #_ + ["#." code]]]) + +(def: random-annotations + (Random Annotations) + (let [name (random.and (random.ascii/alpha 5) + (random.ascii/alpha 5))] + (random.list 5 (random.and name $////code.random)))) + +(def: #export random + (Random /.Definition) + ($_ random.and + (random.ascii/alpha 5) + (random.or $//check.random + $////code.random) + ..random-annotations + random.bit + )) + +(def: compiler + {#.info {#.target "FAKE" + #.version "0.0.0" + #.mode #.Build} + #.source [location.dummy 0 ""] + #.location location.dummy + #.current-module #.None + #.modules (list) + #.scopes (list) + #.type-context {#.ex-counter 0 + #.var-counter 0 + #.var-bindings (list)} + #.expected #.None + #.seed 0 + #.scope-type-vars (list) + #.extensions [] + #.host []}) + +(def: #export test + Test + (<| (_.covering /._) + (_.for [/.Definition]) + ($_ _.and + (_.for [/.equivalence] + ($equivalence.spec /.equivalence ..random)) + + (do random.monad + [expected ..random + + type $////code.random + untyped-value $////code.random] + ($_ _.and + (_.cover [/.write /.parser] + (case (<code>.run (/.parser compiler) + (list (/.write expected))) + (#try.Failure error) + false + + (#try.Success actual) + (\ /.equivalence = expected actual))) + (_.cover [/.typed] + (let [expected (set@ #/.value (#.Left [type untyped-value]) expected)] + (case (<code>.run (/.typed compiler) + (list (/.write expected))) + (#try.Failure error) + false + + (#try.Success actual) + (\ /.equivalence = expected actual)))) + (_.cover [/.lacks-type!] + (let [expected (set@ #/.value (#.Right untyped-value) expected)] + (case (<code>.run (/.typed compiler) + (list (/.write expected))) + (#try.Failure error) + (exception.match? /.lacks-type! error) + + (#try.Success actual) + false))) + ))) + )) diff --git a/stdlib/source/test/lux/math/infix.lux b/stdlib/source/test/lux/math/infix.lux index aeba020d5..d9c15a2e5 100644 --- a/stdlib/source/test/lux/math/infix.lux +++ b/stdlib/source/test/lux/math/infix.lux @@ -1,45 +1,63 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] - [abstract/monad (#+ do)] - ["r" math/random] ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] [data ["." bit ("#\." equivalence)] [number ["n" nat] - ["f" frac]]]] + ["f" frac]]] + [math + ["." random]]] {1 ["." / ["." //]]}) (def: #export test Test - (<| (_.context (%.name (name-of /._))) - (do r.monad - [subject r.nat - parameter r.nat - extra r.nat - angle r.safe-frac] - ($_ _.and - (_.test "Constant values don't change." - (n.= subject - (/.infix subject))) - (_.test "Can call binary functions." - (n.= (n.gcd parameter subject) - (/.infix [subject n.gcd parameter]))) - (_.test "Can call unary functions." - (f.= (//.sin angle) - (/.infix [//.sin angle]))) - (_.test "Can use regular syntax in the middle of infix code." - (n.= (n.gcd extra (n.* parameter subject)) - (/.infix [(n.* parameter subject) n.gcd extra]))) - (_.test "Can use non-numerical functions/macros as operators." - (bit\= (and (n.< parameter subject) (n.< extra parameter)) - (/.infix [[subject n.< parameter] and [parameter n.< extra]]))) - (_.test "Can combine bit operations in special ways via special keywords." - (and (bit\= (and (n.< parameter subject) (n.< extra parameter)) - (/.infix [#and subject n.< parameter n.< extra])) - (bit\= (and (n.< parameter subject) (n.> extra parameter)) - (/.infix [#and subject n.< parameter n.> extra])))) - )))) + (<| (_.covering /._) + (do random.monad + [subject random.nat + parameter random.nat + extra random.nat + angle random.safe-frac + factor random.nat] + (_.cover [/.infix] + (let [constant-values! + (n.= subject + (/.infix subject)) + + unary-functions! + (f.= (//.sin angle) + (/.infix [//.sin angle])) + + binary-functions! + (n.= (n.gcd parameter subject) + (/.infix [subject n.gcd parameter])) + + multiple-binary-functions! + (n.= (n.* factor (n.gcd parameter subject)) + (/.infix [subject n.gcd parameter n.* factor])) + + function-call! + (n.= (n.gcd extra (n.* parameter subject)) + (/.infix [(n.* parameter subject) n.gcd extra])) + + non-numeric! + (bit\= (and (n.< parameter subject) (n.< extra parameter)) + (/.infix [[subject n.< parameter] and [parameter n.< extra]])) + + and-composition! + (and (bit\= (and (n.< parameter subject) (n.< extra parameter)) + (/.infix [#and subject n.< parameter n.< extra])) + (bit\= (and (n.< parameter subject) (n.> extra parameter)) + (/.infix [#and subject n.< parameter n.> extra])))] + (and constant-values! + unary-functions! + binary-functions! + multiple-binary-functions! + function-call! + non-numeric! + and-composition! + )))))) |