From ef78c1f92ab29c4370193591b170535dd9e743f7 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 5 Nov 2020 22:54:05 -0400 Subject: Improved error reporting for syntax macros. --- stdlib/source/test/aedifex.lux | 4 +- stdlib/source/test/aedifex/cli.lux | 4 +- stdlib/source/test/aedifex/parser.lux | 2 +- stdlib/source/test/aedifex/profile.lux | 5 +- stdlib/source/test/aedifex/repository.lux | 93 +++++++++ .../test/lux/data/collection/set/ordered.lux | 232 +++++++++++++-------- stdlib/source/test/lux/meta/annotation.lux | 2 +- stdlib/source/test/lux/world/console.lux | 3 +- 8 files changed, 253 insertions(+), 92 deletions(-) create mode 100644 stdlib/source/test/aedifex/repository.lux (limited to 'stdlib/source/test') diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux index a4fd15bec..c9994aafa 100644 --- a/stdlib/source/test/aedifex.lux +++ b/stdlib/source/test/aedifex.lux @@ -21,7 +21,8 @@ ["#." cli] ["#." hash] ["#." parser] - ["#." pom]]) + ["#." pom] + ["#." repository]]) (def: test Test @@ -41,6 +42,7 @@ /hash.test /parser.test /pom.test + /repository.test )) (program: args diff --git a/stdlib/source/test/aedifex/cli.lux b/stdlib/source/test/aedifex/cli.lux index 0dde0402a..1edfb381f 100644 --- a/stdlib/source/test/aedifex/cli.lux +++ b/stdlib/source/test/aedifex/cli.lux @@ -18,8 +18,8 @@ {#program ["." / ["/#" // #_ - ["#" profile] - [upload (#+ User Password)]]]}) + [repository (#+ User Password)] + ["#" profile]]]}) (def: compilation (Random /.Compilation) diff --git a/stdlib/source/test/aedifex/parser.lux b/stdlib/source/test/aedifex/parser.lux index e26240562..12fa349bb 100644 --- a/stdlib/source/test/aedifex/parser.lux +++ b/stdlib/source/test/aedifex/parser.lux @@ -29,7 +29,7 @@ ["#" profile] ["#." project (#+ Project)] ["#." artifact (#+ Artifact)] - ["#." dependency (#+ Repository Dependency)] + ["#." dependency (#+ Dependency)] ["#." format]]]}) (def: name diff --git a/stdlib/source/test/aedifex/profile.lux b/stdlib/source/test/aedifex/profile.lux index d0da1ff2a..10d921f94 100644 --- a/stdlib/source/test/aedifex/profile.lux +++ b/stdlib/source/test/aedifex/profile.lux @@ -28,7 +28,8 @@ {#program ["." / ["/#" // #_ - ["#." dependency (#+ Repository Dependency)] + [repository (#+ Address)] + ["#." dependency (#+ Dependency)] ["#." format]]]}) (def: distribution @@ -103,7 +104,7 @@ (random.ascii/alpha 1)) (def: repository - (Random Repository) + (Random Address) (random.ascii/alpha 1)) (def: source diff --git a/stdlib/source/test/aedifex/repository.lux b/stdlib/source/test/aedifex/repository.lux new file mode 100644 index 000000000..4f96d9329 --- /dev/null +++ b/stdlib/source/test/aedifex/repository.lux @@ -0,0 +1,93 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + ["." hash (#+ Hash)] + ["." equivalence (#+ Equivalence)] + ["." monad (#+ do)]] + [control + ["." io] + ["." try] + ["." exception (#+ exception:)]] + [data + ["." binary (#+ Binary)] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary (#+ Dictionary)]]] + [math + ["." random (#+ Random)]]] + [// + ["@." artifact]] + {#spec + ["$." /]} + {#program + ["." / (#+ Identity) + ["/#" // #_ + ["#." artifact (#+ Version Artifact) + ["#/." extension (#+ Extension)]]]]}) + +(def: identity + (Random Identity) + (random.and (random.ascii/alpha 10) + (random.ascii/alpha 10))) + +(def: identity-equivalence + (Equivalence Identity) + (equivalence.product text.equivalence + text.equivalence)) + +(def: artifact + (-> Version Artifact) + (|>> ["com.github.luxlang" "test-artifact"])) + +(def: item-hash + (Hash [Artifact Extension]) + (hash.product //artifact.hash + text.hash)) + +(exception: (not-found {artifact Artifact} + {extension Extension}) + (exception.report + ["Artifact" (//artifact.format artifact)] + ["Extension" (%.text extension)])) + +(exception: (invalid-identity {[user _] Identity}) + (exception.report + ["User" (%.text user)])) + +(type: Store + (Dictionary [Artifact Extension] Binary)) + +(def: empty + Store + (dictionary.new ..item-hash)) + +(structure: (simulation identity) + (-> Identity (/.Simulation Store)) + + (def: (on-download artifact extension state) + (case (dictionary.get [artifact extension] state) + (#.Some content) + (exception.return [state content]) + + #.None + (exception.throw ..not-found [artifact extension]))) + (def: (on-upload requester artifact extension content state) + (if (:: identity-equivalence = identity requester) + (exception.return (dictionary.put [artifact extension] content state)) + (exception.throw ..invalid-identity [requester])))) + +(def: #export test + Test + (<| (_.covering /._) + (do {! random.monad} + [valid ..identity + invalid (random.filter (|>> (:: identity-equivalence = valid) not) + ..identity)] + ($_ _.and + (_.with-cover [/.mock /.Simulation] + ($/.spec valid (..artifact "1.2.3-YES") + invalid (..artifact "4.5.6-NO") + (/.mock (..simulation valid) ..empty))) + )))) diff --git a/stdlib/source/test/lux/data/collection/set/ordered.lux b/stdlib/source/test/lux/data/collection/set/ordered.lux index 335eb0226..7257a7f7b 100644 --- a/stdlib/source/test/lux/data/collection/set/ordered.lux +++ b/stdlib/source/test/lux/data/collection/set/ordered.lux @@ -1,6 +1,5 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] [abstract [monad (#+ do)] @@ -9,105 +8,170 @@ [/ ["$." equivalence]]}] [data + ["." bit ("#@." equivalence)] [number ["n" nat]] [collection ["." list]]] [math - ["r" random (#+ Random) ("#@." monad)]]] + ["." random (#+ Random) ("#@." monad)]]] {1 ["." / (#+ Set) ["." //]]}) -(def: gen-nat - (r.Random Nat) - (|> r.nat - (:: r.monad map (n.% 100)))) +(def: size + (random.Random Nat) + (:: random.monad map (n.% 100) random.nat)) -(def: #export (set &order gen-value size) - (All [a] (-> (Order a) (Random a) Nat (Random (Set a)))) +(def: #export (random size &order gen-value) + (All [a] (-> Nat (Order a) (Random a) (Random (Set a)))) (case size 0 - (r@wrap (/.new &order)) + (random@wrap (/.new &order)) _ - (do r.monad - [partial (set &order gen-value (dec size)) - value (r.filter (|>> (/.member? partial) not) - gen-value)] + (do random.monad + [partial (random (dec size) &order gen-value) + value (random.filter (|>> (/.member? partial) not) + gen-value)] (wrap (/.add value partial))))) (def: #export test Test - (<| (_.context (%.name (name-of /.Set))) - ($_ _.and - (do r.monad - [size gen-nat] - ($_ _.and - ($equivalence.spec /.equivalence (..set n.order r.nat size)) - )) - (do {! r.monad} - [sizeL gen-nat - sizeR gen-nat - listL (|> (r.set n.hash sizeL gen-nat) (:: ! map //.to-list)) - listR (|> (r.set n.hash sizeR gen-nat) (:: ! map //.to-list)) - #let [(^open "/@.") /.equivalence - setL (/.from-list n.order listL) - setR (/.from-list n.order listR) - sortedL (list.sort n.< listL) - minL (list.head sortedL) - maxL (list.last sortedL)]] - ($_ _.and - (_.test "I can query the size of a set." - (n.= sizeL (/.size setL))) - (_.test "Can query minimum value." - (case [(/.min setL) minL] - [#.None #.None] - true - - [(#.Some reference) (#.Some sample)] - (n.= reference sample) - - _ - false)) - (_.test "Can query maximum value." - (case [(/.max setL) maxL] - [#.None #.None] - true - - [(#.Some reference) (#.Some sample)] - (n.= reference sample) - - _ - false)) - (_.test "Converting sets to/from lists can't change their values." - (|> setL - /.to-list (/.from-list n.order) - (/@= setL))) - (_.test "Order is preserved." - (let [listL (/.to-list setL) - (^open "list@.") (list.equivalence n.equivalence)] - (list@= listL - (list.sort n.< listL)))) - (_.test "Every set is a sub-set of the union of itself with another." - (let [setLR (/.union setL setR)] - (and (/.sub? setLR setL) - (/.sub? setLR setR)))) - (_.test "Every set is a super-set of the intersection of itself with another." - (let [setLR (/.intersection setL setR)] - (and (/.super? setLR setL) - (/.super? setLR setR)))) - (_.test "Union with the empty set leaves a set unchanged." - (/@= setL - (/.union (/.new n.order) - setL))) - (_.test "Intersection with the empty set results in the empty set." - (let [empty-set (/.new n.order)] - (/@= empty-set - (/.intersection empty-set setL)))) - (_.test "After substracting a set A from another B, no member of A can be a member of B." - (let [sub (/.difference setR setL)] - (not (list.any? (/.member? sub) (/.to-list setR))))) - (_.test "Every member of a set must be identifiable." - (list.every? (/.member? setL) (/.to-list setL))) + (<| (_.covering /._) + (_.with-cover [/.Set]) + (do {! random.monad} + [sizeL ..size + sizeR ..size + usetL (random.set n.hash sizeL random.nat) + non-memberL (random.filter (|>> (//.member? usetL) not) + random.nat) + #let [listL (//.to-list usetL)] + listR (|> (random.set n.hash sizeR random.nat) (:: ! map //.to-list)) + #let [(^open "/@.") /.equivalence + setL (/.from-list n.order listL) + setR (/.from-list n.order listR) + empty (/.new n.order)]] + (`` ($_ _.and + (_.with-cover [/.equivalence] + ($equivalence.spec /.equivalence (..random sizeL n.order random.nat))) + + (_.cover [/.size] + (n.= sizeL (/.size setL))) + (_.cover [/.empty?] + (bit@= (n.= 0 (/.size setL)) + (/.empty? setL))) + (_.cover [/.new] + (/.empty? (/.new n.order))) + (_.cover [/.to-list] + (:: (list.equivalence n.equivalence) = + (/.to-list (/.from-list n.order listL)) + (list.sort (:: n.order <) listL))) + (_.cover [/.from-list] + (|> setL + /.to-list (/.from-list n.order) + (/@= setL))) + (~~ (template [ ] + [(_.cover [] + (case ( setL) + (#.Some value) + (|> setL /.to-list (list.every? ( value))) + + #.None + (/.empty? setL)))] + + [/.min n.>=] + [/.max n.<=] + )) + (_.cover [/.member?] + (let [members-are-identified! + (list.every? (/.member? setL) (/.to-list setL)) + + non-members-are-not-identified! + (not (/.member? setL non-memberL))] + (and members-are-identified! + non-members-are-not-identified!))) + (_.cover [/.add] + (let [setL+ (/.add non-memberL setL)] + (and (not (/.member? setL non-memberL)) + (/.member? setL+ non-memberL) + (n.= (inc (/.size setL)) + (/.size setL+))))) + (_.cover [/.remove] + (|> setL + (/.add non-memberL) + (/.remove non-memberL) + (:: /.equivalence = setL))) + (_.cover [/.sub?] + (let [self! + (/.sub? setL setL) + + empty! + (/.sub? setL empty)] + (and self! + empty!))) + (_.cover [/.super?] + (let [self! + (/.super? setL setL) + + empty! + (/.super? empty setL) + + symmetry! + (bit@= (/.super? setL setR) + (/.sub? setR setL))] + (and self! + empty! + symmetry!))) + (~~ (template [ ] + [(_.cover [] + (let [self! + (:: /.equivalence = + setL + ( setL setL)) + + super! + (and ( ( setL setR) setL) + ( ( setL setR) setR)) + + empty! + (:: /.equivalence = + (if empty setL) + ( setL empty)) + + idempotence! + (:: /.equivalence = + ( setL ( setL setR)) + ( setR ( setL setR)))] + (and self! + super! + empty! + idempotence!)))] + + [/.union /.sub? false] + [/.intersection /.super? true] + )) + (_.cover [/.difference] + (let [self! + (|> setL + (/.difference setL) + (:: /.equivalence = empty)) + + empty! + (|> setL + (/.difference empty) + (:: /.equivalence = setL)) + + difference! + (not (list.any? (/.member? (/.difference setL setR)) + (/.to-list setL))) + + idempotence! + (:: /.equivalence = + (/.difference setL setR) + (/.difference setL (/.difference setL setR)))] + (and self! + empty! + difference! + idempotence!))) ))))) diff --git a/stdlib/source/test/lux/meta/annotation.lux b/stdlib/source/test/lux/meta/annotation.lux index f0ff06160..a3c2dae7f 100644 --- a/stdlib/source/test/lux/meta/annotation.lux +++ b/stdlib/source/test/lux/meta/annotation.lux @@ -74,7 +74,7 @@ [/.nat random.nat code.nat nat.equivalence] [/.int random.int code.int int.equivalence] [/.rev random.rev code.rev rev.equivalence] - [/.frac random.frac code.frac frac.equivalence] + [/.frac random.safe-frac code.frac frac.equivalence] [/.text (random.ascii/alpha 1) code.text text.equivalence] [/.identifier ..random-key code.identifier name.equivalence] [/.tag ..random-key code.tag name.equivalence] diff --git a/stdlib/source/test/lux/world/console.lux b/stdlib/source/test/lux/world/console.lux index d17559cec..6e1ce67b3 100644 --- a/stdlib/source/test/lux/world/console.lux +++ b/stdlib/source/test/lux/world/console.lux @@ -4,6 +4,7 @@ [abstract [monad (#+ do)]] [control + ["." io] ["." try (#+ Try)] ["." exception (#+ exception:)]]] {1 @@ -40,4 +41,4 @@ Test (<| (_.covering /._) (_.with-cover [/.mock /.Simulation] - ($/.spec (/.mock ..simulation false))))) + ($/.spec (io.io (/.mock ..simulation false)))))) -- cgit v1.2.3