diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/abstract/functor.lux | 22 | ||||
| -rw-r--r-- | stdlib/source/lux/control/exception.lux | 36 | ||||
| -rw-r--r-- | stdlib/source/lux/control/security/policy.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/data/collection/tree.lux | 20 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/loader.lux | 25 | ||||
| -rw-r--r-- | stdlib/source/lux/test.lux | 88 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/default/platform.lux | 80 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux | 36 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/meta/archive.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/meta/io/archive.lux | 47 | ||||
| -rw-r--r-- | stdlib/source/program/compositor.lux | 13 | ||||
| -rw-r--r-- | stdlib/source/test/lux/abstract/functor.lux | 84 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/concatenative.lux | 272 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/try.lux | 9 |
14 files changed, 454 insertions, 292 deletions
diff --git a/stdlib/source/lux/abstract/functor.lux b/stdlib/source/lux/abstract/functor.lux index a259673d4..a9fc6796c 100644 --- a/stdlib/source/lux/abstract/functor.lux +++ b/stdlib/source/lux/abstract/functor.lux @@ -9,11 +9,29 @@ (type: #export (Fix f) (f (Fix f))) +(type: #export (Or f g) + (All [a] (| (f a) (g a)))) + +(def: #export (sum (^open "f@.") (^open "g@.")) + (All [F G] (-> (Functor F) (Functor G) (Functor (..Or F G)))) + (structure + (def: (map f fa|ga) + (case fa|ga + (#.Left fa) + (#.Left (f@map f fa)) + + (#.Right ga) + (#.Right (g@map f ga)))))) + (type: #export (And f g) (All [a] (& (f a) (g a)))) -(type: #export (Or f g) - (All [a] (| (f a) (g a)))) +(def: #export (product (^open "f@.") (^open "g@.")) + (All [F G] (-> (Functor F) (Functor G) (Functor (..And F G)))) + (structure + (def: (map f [fa ga]) + [(f@map f fa) + (g@map f ga)]))) (type: #export (Then f g) (All [a] (f (g a)))) diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index 53b770bcd..211976aa2 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -1,4 +1,4 @@ -(.module: {#.doc "Exception-handling functionality built on top of the Error type."} +(.module: {#.doc "Exception-handling functionality."} [lux #* [abstract [monad (#+ do)]] @@ -88,13 +88,13 @@ (s.form (p.and s.local-identifier (p.some scr.typed-input))))} {body (p.maybe s.any)}) {#.doc (doc "Define a new exception type." - "It moslty just serves as a way to tag error messages for later catching." + "It mostly just serves as a way to tag error messages for later catching." "" "Simple case:" (exception: #export some-exception) "" "Complex case:" - (exception: #export [optional type-vars] (some-exception [optional Text] {arguments Int}) + (exception: #export [optional type variables] (some-exception {optional Text} {arguments Int}) optional-body))} (macro.with-gensyms [g!descriptor] (do @ @@ -112,13 +112,13 @@ (~ (maybe.default (' "") body))))}))))) ))) -(def: header-separator ": ") - (def: (report' entries) (-> (List [Text Text]) Text) - (let [largest-header-size (|> entries - (list@map (|>> product.left text.size)) - (list@fold n.max 0)) + (let [header-separator ": " + largest-header-size (list@fold (function (_ [header _] max) + (n.max (text.size header) max)) + 0 + entries) on-new-line (|> " " (list.repeat (n.+ (text.size header-separator) largest-header-size)) @@ -132,7 +132,7 @@ (text.join-with ""))] (|> message (text.replace-all text.new-line on-new-line) - ($_ text@compose padding header ..header-separator))))) + ($_ text@compose padding header header-separator))))) (text.join-with text.new-line)))) (syntax: #export (report {entries (p.many (s.tuple (p.and s.any s.any)))}) @@ -140,6 +140,15 @@ (list@map (function (_ [header message]) (` [(~ header) (~ message)]))))))))))) +(def: #export (enumerate format entries) + (All [a] + (-> (-> a Text) (List a) Text)) + (|> entries + list.enumerate + (list@map (function (_ [index entry]) + [(n@encode index) (format entry)])) + report')) + (def: separator (let [gap ($_ "lux text concat" text.new-line text.new-line) horizontal-line (|> "-" (list.repeat 64) (text.join-with ""))] @@ -168,12 +177,3 @@ success success)) - -(def: #export (enumerate format) - (All [a] - (-> (-> a Text) - (-> (List a) Text))) - (|>> list.enumerate - (list@map (function (_ [index entry]) - ($_ text@compose (n@encode index) ": " (format entry)))) - (text.join-with text.new-line))) diff --git a/stdlib/source/lux/control/security/policy.lux b/stdlib/source/lux/control/security/policy.lux index f61f4c58b..d210f91e1 100644 --- a/stdlib/source/lux/control/security/policy.lux +++ b/stdlib/source/lux/control/security/policy.lux @@ -27,7 +27,7 @@ {#can-upgrade (Can-Upgrade brand label) #can-downgrade (Can-Downgrade brand label)}) - (def: Privilege<_> + (def: privilege Privilege {#can-upgrade (..can-upgrade (|>> :abstraction)) #can-downgrade (..can-downgrade (|>> :representation))}) @@ -53,7 +53,7 @@ (Ex [label] (-> (Context brand scope label) (scope label)))) - (context ..Privilege<_>)) + (context ..privilege)) (def: (decorate constructor) (-> Type Type) diff --git a/stdlib/source/lux/data/collection/tree.lux b/stdlib/source/lux/data/collection/tree.lux index 6daf575a6..a3fb711d3 100644 --- a/stdlib/source/lux/data/collection/tree.lux +++ b/stdlib/source/lux/data/collection/tree.lux @@ -1,10 +1,10 @@ (.module: [lux #* [abstract - functor - [monad (#+ do Monad)] - equivalence - fold] + [functor (#+ Functor)] + [monad (#+ Monad do)] + [equivalence (#+ Equivalence)] + [fold (#+ Fold)]] [control ["p" parser ["s" code (#+ Parser)]]] @@ -55,18 +55,24 @@ (` {#value (~ value) #children (list (~+ (list@map recur children)))}))))))) -(structure: #export (equivalence Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) +(structure: #export (equivalence Equivalence<a>) + (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) + (def: (= tx ty) (and (:: Equivalence<a> = (get@ #value tx) (get@ #value ty)) (:: (list.equivalence (equivalence Equivalence<a>)) = (get@ #children tx) (get@ #children ty))))) -(structure: #export functor (Functor Tree) +(structure: #export functor + (Functor Tree) + (def: (map f fa) {#value (f (get@ #value fa)) #children (list@map (map f) (get@ #children fa))})) -(structure: #export fold (Fold Tree) +(structure: #export fold + (Fold Tree) + (def: (fold f init tree) (list@fold (function (_ tree' init') (fold f init' tree')) (f (get@ #value tree) diff --git a/stdlib/source/lux/target/jvm/loader.lux b/stdlib/source/lux/target/jvm/loader.lux index 3e17d42c8..2764bad4a 100644 --- a/stdlib/source/lux/target/jvm/loader.lux +++ b/stdlib/source/lux/target/jvm/loader.lux @@ -5,7 +5,7 @@ [monad (#+ do)]] [control ["." try (#+ Try)] - ["ex" exception (#+ exception:)] + ["." exception (#+ exception:)] ["." io (#+ IO)] [concurrency ["." atom (#+ Atom)]]] @@ -15,7 +15,6 @@ ["%" format (#+ format)]] [collection ["." array] - ["." list ("#;." functor)] ["." dictionary (#+ Dictionary)]]] ["." host (#+ import: object do-to)]]) @@ -23,18 +22,18 @@ (Atom (Dictionary Text Binary))) (exception: #export (already-stored {class Text}) - (ex.report ["Class" class])) + (exception.report + ["Class" class])) (exception: #export (unknown {class Text} {known-classes (List Text)}) - (ex.report ["Class" class] - ["Known classes" (|> known-classes - (list.sort (:: text.order <)) - (list;map (|>> (format text.new-line text.tab))) - (text.join-with ""))])) + (exception.report + ["Class" class] + ["Known classes" (exception.enumerate (|>>) known-classes)])) (exception: #export (cannot-define {class Text} {error Text}) - (ex.report ["Class" class] - ["Error" error])) + (exception.report + ["Class" class] + ["Error" error])) (import: #long java/lang/Object (getClass [] (java/lang/Class java/lang/Object))) @@ -116,17 +115,17 @@ (:assume class) (#try.Failure error) - (error! (ex.construct ..cannot-define [class-name error]))) + (error! (exception.construct ..cannot-define [class-name error]))) #.None - (error! (ex.construct ..unknown [class-name (dictionary.keys classes)])))))))))) + (error! (exception.construct ..unknown [class-name (dictionary.keys classes)])))))))))) (def: #export (store name bytecode library) (-> Text Binary Library (IO (Try Any))) (do io.monad [library' (atom.read library)] (if (dictionary.contains? name library') - (wrap (ex.throw ..already-stored name)) + (wrap (exception.throw ..already-stored name)) (do @ [_ (atom.update (dictionary.put name bytecode) library)] (wrap (#try.Success [])))))) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index cca7205fd..18f487ff4 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -10,10 +10,12 @@ ["<>" parser ["<c>" code]]] [data + ["." maybe] ["." product] ["." name] [number - ["n" nat]] + ["n" nat] + ["f" frac]] ["." text ["%" format (#+ format)]] [collection @@ -162,17 +164,48 @@ (-> Duration Counters Text) (let [successes (get@ #successes counters) failures (get@ #failures counters) - missing-coverage (set.difference (get@ #actual-coverage counters) - (get@ #expected-coverage counters)) - unexpected-coverage (set.difference (get@ #expected-coverage counters) - (get@ #actual-coverage counters))] + missing (set.difference (get@ #actual-coverage counters) + (get@ #expected-coverage counters)) + unexpected (set.difference (get@ #expected-coverage counters) + (get@ #actual-coverage counters)) + report (: (-> (Set Name) Text) + (|>> set.to-list + (list.sort (:: name.order <)) + (exception.enumerate %.name))) + expected-definitions-to-cover (set.size (get@ #expected-coverage counters)) + actual-definitions-covered (set.size (get@ #actual-coverage counters)) + coverage (case expected-definitions-to-cover + 0 "N/A" + expected (let [missing-ratio (f./ (n.frac expected) + (n.frac (set.size missing))) + max-percent +100.0 + done-percent (|> +1.0 + (f.- missing-ratio) + (f.* max-percent))] + (if (f.= max-percent done-percent) + "100%" + (let [raw (|> done-percent + %.frac + (text.replace-once "+" ""))] + (|> raw + (text.clip 0 (if (f.>= +10.0 done-percent) + 5 ## XX.XX + 4 ## X.XX + )) + (maybe.default raw) + (text.suffix "%"))))))] (exception.report ["Duration" (%.duration duration)] - ["Tests" (%.nat (n.+ successes failures))] - ["Successes" (%.nat successes)] - ["Failures" (%.nat failures)] - ["Missing Coverage" (|> missing-coverage set.to-list (exception.enumerate %.name))] - ["Unexpected Coverage" (|> unexpected-coverage set.to-list (exception.enumerate %.name))]))) + ["# Tests" (%.nat (n.+ successes failures))] + ["# Successes" (%.nat successes)] + ["# Failures" (%.nat failures)] + ["# Expected definitions to cover" (%.nat expected-definitions-to-cover)] + ["# Actual definitions covered" (%.nat actual-definitions-covered)] + ["# Pending definitions to cover" (%.nat (n.- actual-definitions-covered + expected-definitions-to-cover))] + ["Coverage" coverage] + ["Missing definitions to cover" (report missing)] + ["Unexpected definitions covered" (report unexpected)]))) (def: failure-exit-code -1) (def: success-exit-code +0) @@ -193,8 +226,8 @@ 0 ..success-exit-code _ ..failure-exit-code))))) -(def: (cover' coverage condition) - (-> (List Name) Bit Test) +(def: (claim' coverage condition) + (-> (List Name) Bit Assertion) (let [message (|> coverage (list@map %.name) (text.join-with " & ")) @@ -202,8 +235,12 @@ (|> (..assert message condition) (promise@map (function (_ [counters documentation]) [(update@ #actual-coverage (set.union coverage) counters) - documentation])) - (:: random.monad wrap)))) + documentation]))))) + +(def: (cover' coverage condition) + (-> (List Name) Bit Test) + (|> (claim' coverage condition) + (:: random.monad wrap))) (def: (with-cover' coverage test) (-> (List Name) Test Test) @@ -226,15 +263,20 @@ [_ (macro.find-export name)] (wrap (list (name-code name))))) -(syntax: #export (cover {coverage (<c>.tuple (<>.many <c>.any))} - condition) - (let [coverage (list@map (function (_ definition) - (` ((~! ..reference) (~ definition)))) - coverage)] - (wrap (list (` ((~! ..cover') - (: (.List .Name) - (.list (~+ coverage))) - (~ condition))))))) +(template [<macro> <function>] + [(syntax: #export (<macro> {coverage (<c>.tuple (<>.many <c>.any))} + condition) + (let [coverage (list@map (function (_ definition) + (` ((~! ..reference) (~ definition)))) + coverage)] + (wrap (list (` ((~! <function>) + (: (.List .Name) + (.list (~+ coverage))) + (~ condition)))))))] + + [claim ..claim'] + [cover ..cover'] + ) (syntax: #export (with-cover {coverage (<c>.tuple (<>.many <c>.any))} test) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 7707a154c..86a1dea87 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -15,7 +15,8 @@ ["." text ["%" format (#+ format)]] [collection - ["." row]] + ["." row] + ["." set]] [format ["_" binary (#+ Writer)]]] [world @@ -27,15 +28,19 @@ [language [lux ["$" /] + ["#." version] ["." syntax] ["#." analysis [macro (#+ Expander)]] ["#." generation (#+ Buffer)] ["#." directive] [phase - [extension (#+ Extender)]]]] + [extension (#+ Extender)] + [analysis + ["." module]]]]] [meta ["." archive (#+ Archive) + ["." artifact (#+ Registry)] ["." descriptor (#+ Descriptor Module)] ["." document (#+ Document)]] [io @@ -49,7 +54,7 @@ {#&file-system (file.System Promise) #host (///generation.Host expression directive) #phase (///generation.Phase anchor expression directive) - #runtime (///generation.Operation anchor expression directive Any) + #runtime (///generation.Operation anchor expression directive [Registry Output]) #write (-> directive Binary)}) ## TODO: Get rid of this @@ -71,9 +76,9 @@ (_.and descriptor.writer (document.writer $.writer))) - (def: (cache-module platform host target-dir module-file-name module-id extension [[descriptor document] output]) + (def: (cache-module platform host target-dir module-id extension [[descriptor document] output]) (All <type-vars> - (-> <Platform> Host Path Path archive.ID Text [[Descriptor (Document Any)] Output] + (-> <Platform> Host Path archive.ID Text [[Descriptor (Document Any)] Output] (Promise (Try Any)))) (let [system (get@ #&file-system platform) write-artifact! (: (-> [Text Binary] (Action Any)) @@ -97,10 +102,41 @@ (///generation.set-buffer ///generation.empty-buffer)) ## TODO: Inline ASAP - (def: compile-runtime! + (def: (compile-runtime! platform) (All <type-vars> - (-> <Platform> (///generation.Operation anchor expression directive Any))) - (get@ #runtime)) + (-> <Platform> (///generation.Operation anchor expression directive [Registry Output]))) + (do ///phase.monad + [_ ..initialize-buffer!] + (get@ #runtime platform))) + + (def: (runtime-descriptor registry) + (-> Registry Descriptor) + {#descriptor.hash 0 + #descriptor.name archive.runtime-module + #descriptor.file "" + #descriptor.references (set.new text.hash) + #descriptor.state #.Compiled + #descriptor.registry registry}) + + (def: runtime-document + (Document .Module) + (document.write $.key (module.new 0))) + + (def: (process-runtime analysis-state archive platform) + (All <type-vars> + (-> .Lux Archive <Platform> + (///directive.Operation anchor expression directive + [Archive [[Descriptor (Document .Module)] Output]]))) + (do ///phase.monad + [_ (///directive.lift-analysis + (///analysis.install analysis-state)) + [registry payload] (///directive.lift-generation + (..compile-runtime! platform)) + #let [descriptor,document [(..runtime-descriptor registry) ..runtime-document]] + archive (///phase.lift (do try.monad + [[_ archive] (archive.reserve archive.runtime-module archive)] + (archive.add archive.runtime-module descriptor,document archive)))] + (wrap [archive [descriptor,document payload]]))) (def: #export (initialize extension target host module expander host-analysis platform generation-bundle host-directive-bundle program extender) (All <type-vars> @@ -115,7 +151,7 @@ (///directive.Bundle anchor expression directive) (-> expression directive) Extender - (Promise (Try [<State+> Archive (Buffer directive)])))) + (Promise (Try [<State+> Archive])))) (let [state (//init.state host module expander @@ -128,18 +164,12 @@ extender)] (do (try.with promise.monad) [_ (ioW.enable (get@ #&file-system platform) host target) - [archive analysis-state] (ioW.thaw extension (get@ #host platform) (get@ #&file-system platform) host target)] - (|> (do ///phase.monad - [_ (///directive.lift-analysis - (///analysis.install analysis-state))] - (///directive.lift-generation - (do ///phase.monad - [_ ..initialize-buffer! - _ (..compile-runtime! platform) - buffer ///generation.buffer] - (wrap [archive buffer])))) - (///phase.run' state) - promise@wrap)))) + [archive analysis-state] (ioW.thaw extension (get@ #host platform) (get@ #&file-system platform) host target) + [state [archive payload]] (|> (process-runtime analysis-state archive platform) + (///phase.run' state) + promise@wrap) + _ (..cache-module platform host target 0 extension payload)] + (wrap [state archive])))) (def: #export (compile target partial-host-extension expander platform host configuration archive extension state) (All <type-vars> @@ -204,13 +234,7 @@ (#.Right payload) (do (try.with promise.monad) - [_ (..cache-module platform - host - target - (get@ #///.file input) - module-id - extension - payload) + [_ (..cache-module platform host target module-id extension payload) #let [[descriptor+document output] payload]] (case (archive.add module descriptor+document archive) (#try.Success archive) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux index 9fae1fa1e..a4022d942 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux @@ -5,7 +5,7 @@ [control pipe ["." try] - ["ex" exception (#+ exception:)]] + ["." exception (#+ exception:)]] [data ["." text ("#@." equivalence) ["%" format (#+ format)]] @@ -24,35 +24,41 @@ (type: #export Tag Text) (exception: #export (unknown-module {module Text}) - (ex.report ["Module" module])) + (exception.report + ["Module" module])) (exception: #export (cannot-declare-tag-twice {module Text} {tag Text}) - (ex.report ["Module" module] - ["Tag" tag])) + (exception.report + ["Module" module] + ["Tag" tag])) (template [<name>] [(exception: #export (<name> {tags (List Text)} {owner Type}) - (ex.report ["Tags" (text.join-with " " tags)] - ["Type" (%.type owner)]))] + (exception.report + ["Tags" (text.join-with " " tags)] + ["Type" (%.type owner)]))] [cannot-declare-tags-for-unnamed-type] [cannot-declare-tags-for-foreign-type] ) (exception: #export (cannot-define-more-than-once {name Name}) - (ex.report ["Definition" (%.name name)])) + (exception.report + ["Definition" (%.name name)])) (exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State}) - (ex.report ["Module" module] - ["Desired state" (case state - #.Active "Active" - #.Compiled "Compiled" - #.Cached "Cached")])) + (exception.report + ["Module" module] + ["Desired state" (case state + #.Active "Active" + #.Compiled "Compiled" + #.Cached "Cached")])) (exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code}) - (ex.report ["Module" module] - ["Old annotations" (%.code old)] - ["New annotations" (%.code new)])) + (exception.report + ["Module" module] + ["Old annotations" (%.code old)] + ["New annotations" (%.code new)])) (def: #export (new hash) (-> Nat Module) diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux index 49358065b..2f84ad4dd 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive.lux @@ -63,19 +63,21 @@ (type: #export ID Nat) +(def: #export runtime-module Module "") + (abstract: #export Archive {} (Dictionary Module [ID (Maybe [Descriptor (Document Any)])]) - (def: #export empty - Archive - (:abstraction (dictionary.new text.hash))) - (def: next (-> Archive ID) (|>> :representation dictionary.size)) + (def: #export empty + Archive + (:abstraction (dictionary.new text.hash))) + (def: #export (id module archive) (-> Module Archive (Try ID)) (case (dictionary.get module (:representation archive)) diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux index c6865ebc1..7843b9435 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux @@ -186,25 +186,34 @@ (-> Text (generation.Host expression directive) archive.ID (Row Artifact) (Dictionary Text Binary) (Document .Module) (Try (Document .Module)))) (do try.monad - [values (|> expected - row.to-list - (monad.fold @ (function (_ [artifact-id artifact-name] values) - (do @ - [data (try.from-maybe (dictionary.get (format (%.nat artifact-id) extension) actual)) - #let [context [module-id artifact-id] - directive (:: host ingest context data)]] - (case artifact-name - #.None - (do @ - [_ (:: host re-learn context directive)] - (wrap values)) - - (#.Some artifact-name) - (do @ - [value (:: host re-load context directive)] - (wrap (dictionary.put artifact-name value values)))))) - (: (Dictionary Text Any) - (dictionary.new text.hash)))) + [values (: (Try (Dictionary Text Any)) + (loop [input (row.to-list expected) + values (: (Dictionary Text Any) + (dictionary.new text.hash))] + (case input + (#.Cons [[artifact-id artifact-name] input']) + (case (do @ + [data (try.from-maybe (dictionary.get (format (%.nat artifact-id) extension) actual)) + #let [context [module-id artifact-id] + directive (:: host ingest context data)]] + (case artifact-name + #.None + (do @ + [_ (:: host re-learn context directive)] + (wrap values)) + + (#.Some artifact-name) + (do @ + [value (:: host re-load context directive)] + (wrap (dictionary.put artifact-name value values))))) + (#try.Success values') + (recur input' values') + + failure + failure) + + #.None + (#try.Success values)))) content (document.read $.key document) definitions (monad.map @ (function (_ [def-name def-global]) (case def-global diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index 3d40111f7..fcf05f164 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -120,13 +120,12 @@ (#/cli.Compilation configuration) (<| (or-crash! "Compilation failed:") (do (try.with promise.monad) - [[state archive runtime-buffer] (:share [<parameters>] - {(Platform <parameters>) - platform} - {(Promise (Try [(directive.State+ <parameters>) - Archive - (Buffer artifact)])) - (platform.initialize extension target host (get@ #/cli.module configuration) expander host-analysis platform generation-bundle host-directive-bundle program extender)}) + [[state archive] (:share [<parameters>] + {(Platform <parameters>) + platform} + {(Promise (Try [(directive.State+ <parameters>) + Archive])) + (platform.initialize extension target host (get@ #/cli.module configuration) expander host-analysis platform generation-bundle host-directive-bundle program extender)}) [archive state] (:share [<parameters>] {(Platform <parameters>) platform} diff --git a/stdlib/source/test/lux/abstract/functor.lux b/stdlib/source/test/lux/abstract/functor.lux index 388a66ffc..0702f00ef 100644 --- a/stdlib/source/test/lux/abstract/functor.lux +++ b/stdlib/source/test/lux/abstract/functor.lux @@ -2,15 +2,19 @@ [lux #* ["_" test (#+ Test)] ["%" data/text/format (#+ format)] - ["r" math/random] [abstract [equivalence (#+ Equivalence)] [monad (#+ do)]] [control ["." function]] [data + ["." maybe] [number - ["n" nat]]]] + ["n" nat]] + [collection + ["." list]]] + [math + ["." random]]] {1 ["." / (#+ Functor)]}) @@ -24,8 +28,8 @@ (def: (identity injection comparison (^open "/@.")) (All [f] (-> (Injection f) (Comparison f) (Functor f) Test)) - (do r.monad - [sample (:: @ map injection r.nat)] + (do random.monad + [sample (:: @ map injection random.nat)] (_.test "Identity." ((comparison n.=) (/@map function.identity sample) @@ -33,9 +37,9 @@ (def: (homomorphism injection comparison (^open "/@.")) (All [f] (-> (Injection f) (Comparison f) (Functor f) Test)) - (do r.monad - [sample r.nat - increase (:: @ map n.+ r.nat)] + (do random.monad + [sample random.nat + increase (:: @ map n.+ random.nat)] (_.test "Homomorphism." ((comparison n.=) (/@map increase (injection sample)) @@ -43,10 +47,10 @@ (def: (composition injection comparison (^open "/@.")) (All [f] (-> (Injection f) (Comparison f) (Functor f) Test)) - (do r.monad - [sample (:: @ map injection r.nat) - increase (:: @ map n.+ r.nat) - decrease (:: @ map n.- r.nat)] + (do random.monad + [sample (:: @ map injection random.nat) + increase (:: @ map n.+ random.nat) + decrease (:: @ map n.- random.nat)] (_.test "Composition." ((comparison n.=) (|> sample (/@map increase) (/@map decrease)) @@ -54,9 +58,55 @@ (def: #export (spec injection comparison functor) (All [f] (-> (Injection f) (Comparison f) (Functor f) Test)) - (_.context (%.name (name-of /.Functor)) - ($_ _.and - (..identity injection comparison functor) - (..homomorphism injection comparison functor) - (..composition injection comparison functor) - ))) + (<| (_.with-cover [/.Functor]) + ($_ _.and + (..identity injection comparison functor) + (..homomorphism injection comparison functor) + (..composition injection comparison functor) + ))) + +(def: #export test + Test + (do random.monad + [left random.nat + right random.nat + shift random.nat] + (<| (_.covering /._) + ($_ _.and + (_.cover [/.Or /.sum] + (and (case (:: (/.sum maybe.functor list.functor) map + (n.+ shift) + (#.Left (#.Some left))) + (#.Left (#.Some actual)) + (n.= (n.+ shift left) actual) + + _ + false) + (case (:: (/.sum maybe.functor list.functor) map + (n.+ shift) + (#.Right (list right))) + (^ (#.Right (list actual))) + (n.= (n.+ shift right) actual) + + _ + false))) + (_.cover [/.And /.product] + (case (:: (/.product maybe.functor list.functor) map + (n.+ shift) + [(#.Some left) (list right)]) + (^ [(#.Some actualL) (list actualR)]) + (and (n.= (n.+ shift left) actualL) + (n.= (n.+ shift right) actualR)) + + _ + false)) + (_.cover [/.Then /.compose] + (case (:: (/.compose maybe.functor list.functor) map + (n.+ shift) + (#.Some (list left))) + (^ (#.Some (list actual))) + (n.= (n.+ shift left) actual) + + _ + false)) + )))) diff --git a/stdlib/source/test/lux/control/concatenative.lux b/stdlib/source/test/lux/control/concatenative.lux index c649128b0..6701916fc 100644 --- a/stdlib/source/test/lux/control/concatenative.lux +++ b/stdlib/source/test/lux/control/concatenative.lux @@ -27,70 +27,70 @@ [sample random.nat dummy random.nat] (`` ($_ _.and - (_.test (%.name (name-of /.push)) - (n.= sample - (||> (/.push sample)))) - (_.test (%.name (name-of /.drop)) - (n.= sample - (||> (/.push sample) - (/.push dummy) - /.drop))) - (_.test (%.name (name-of /.nip)) - (n.= sample - (||> (/.push dummy) - (/.push sample) - /.nip))) - (_.test (%.name (name-of /.dup)) - (||> (/.push sample) - /.dup - /.n/=)) - (_.test (%.name (name-of /.swap)) - (n.= sample - (||> (/.push sample) - (/.push dummy) - /.swap))) - (_.test (%.name (name-of /.rotL)) - (n.= sample - (||> (/.push sample) - (/.push dummy) - (/.push dummy) - /.rotL))) - (_.test (%.name (name-of /.rotR)) - (n.= sample - (||> (/.push dummy) - (/.push sample) - (/.push dummy) - /.rotR))) - (_.test (%.name (name-of /.&&)) - (let [[left right] (||> (/.push sample) - (/.push dummy) - /.&&)] - (and (n.= sample left) - (n.= dummy right)))) + (_.cover [/.push] + (n.= sample + (||> (/.push sample)))) + (_.cover [/.drop] + (n.= sample + (||> (/.push sample) + (/.push dummy) + /.drop))) + (_.cover [/.nip] + (n.= sample + (||> (/.push dummy) + (/.push sample) + /.nip))) + (_.cover [/.dup] + (||> (/.push sample) + /.dup + /.n/=)) + (_.cover [/.swap] + (n.= sample + (||> (/.push sample) + (/.push dummy) + /.swap))) + (_.cover [/.rotL] + (n.= sample + (||> (/.push sample) + (/.push dummy) + (/.push dummy) + /.rotL))) + (_.cover [/.rotR] + (n.= sample + (||> (/.push dummy) + (/.push sample) + (/.push dummy) + /.rotR))) + (_.cover [/.&&] + (let [[left right] (||> (/.push sample) + (/.push dummy) + /.&&)] + (and (n.= sample left) + (n.= dummy right)))) (~~ (template [<function> <tag>] - [(_.test (%.name (name-of <function>)) - ((sum.equivalence n.= n.=) - (<tag> sample) - (||> (/.push sample) - <function>)))] + [(_.cover [<function>] + ((sum.equivalence n.= n.=) + (<tag> sample) + (||> (/.push sample) + <function>)))] [/.||L #.Left] [/.||R #.Right])) - (_.test (%.name (name-of /.dip)) - (n.= (inc sample) - (||> (/.push sample) - (/.push dummy) - (/.push (/.apply/1 inc)) - /.dip - /.drop))) - (_.test (%.name (name-of /.dip/2)) - (n.= (inc sample) - (||> (/.push sample) - (/.push dummy) - (/.push dummy) - (/.push (/.apply/1 inc)) - /.dip/2 - /.drop /.drop))) + (_.cover [/.dip] + (n.= (inc sample) + (||> (/.push sample) + (/.push dummy) + (/.push (/.apply/1 inc)) + /.dip + /.drop))) + (_.cover [/.dip/2] + (n.= (inc sample) + (||> (/.push sample) + (/.push dummy) + (/.push dummy) + (/.push (/.apply/1 inc)) + /.dip/2 + /.drop /.drop))) )))) (template: (!numerical <=> <generator> <filter> <arithmetic> <order>) @@ -102,19 +102,19 @@ subject <generator>] (`` ($_ _.and (~~ (template [<concatenative> <functional>] - [(_.test (%.name (name-of <concatenative>)) - (<=> (<functional> parameter subject) - (||> (/.push subject) - (/.push parameter) - <concatenative>)))] + [(_.cover [<concatenative>] + (<=> (<functional> parameter subject) + (||> (/.push subject) + (/.push parameter) + <concatenative>)))] <arithmetic>')) (~~ (template [<concatenative> <functional>] - [(_.test (%.name (name-of <concatenative>)) - (bit@= (<functional> parameter subject) - (||> (/.push subject) - (/.push parameter) - <concatenative>)))] + [(_.cover [<concatenative>] + (bit@= (<functional> parameter subject) + (||> (/.push subject) + (/.push parameter) + <concatenative>)))] <order>')) )))))) @@ -146,67 +146,67 @@ |inc| (/.apply/1 inc) |test| (/.apply/1 (|>> (n.- start) (n.< distance)))]] ($_ _.and - (_.test (%.name (name-of /.call)) - (n.= (inc sample) - (||> (/.push sample) - (/.push (/.apply/1 inc)) - /.call))) - (_.test (%.name (name-of /.if)) - (n.= (if choice - (inc sample) - (dec sample)) - (||> (/.push sample) - (/.push choice) - (/.push (/.apply/1 inc)) - (/.push (/.apply/1 dec)) - /.if))) - (_.test (%.name (name-of /.loop)) - (n.= (n.+ distance start) - (||> (/.push start) - (/.push (|>> |inc| /.dup |test|)) - /.loop))) - (_.test (%.name (name-of /.while)) - (n.= (n.+ distance start) - (||> (/.push start) - (/.push (|>> /.dup |test|)) - (/.push |inc|) - /.while))) - (_.test (%.name (name-of /.do)) - (n.= (inc sample) - (||> (/.push sample) - (/.push (|>> (/.push false))) - (/.push |inc|) - /.do /.while))) - (_.test (%.name (name-of /.compose)) - (n.= (inc (inc sample)) - (||> (/.push sample) - (/.push |inc|) - (/.push |inc|) - /.compose - /.call))) - (_.test (%.name (name-of /.curry)) - (n.= (n.+ sample sample) - (||> (/.push sample) - (/.push sample) - (/.push (/.apply/2 n.+)) - /.curry - /.call))) - (_.test (%.name (name-of /.when)) - (n.= (if choice - (inc sample) - sample) - (||> (/.push sample) - (/.push choice) - (/.push (/.apply/1 inc)) - /.when))) - (_.test (%.name (name-of /.?)) - (n.= (if choice - (inc sample) - (dec sample)) - (||> (/.push choice) - (/.push (inc sample)) - (/.push (dec sample)) - /.?))) + (_.cover [/.call] + (n.= (inc sample) + (||> (/.push sample) + (/.push (/.apply/1 inc)) + /.call))) + (_.cover [/.if] + (n.= (if choice + (inc sample) + (dec sample)) + (||> (/.push sample) + (/.push choice) + (/.push (/.apply/1 inc)) + (/.push (/.apply/1 dec)) + /.if))) + (_.cover [/.loop] + (n.= (n.+ distance start) + (||> (/.push start) + (/.push (|>> |inc| /.dup |test|)) + /.loop))) + (_.cover [/.while] + (n.= (n.+ distance start) + (||> (/.push start) + (/.push (|>> /.dup |test|)) + (/.push |inc|) + /.while))) + (_.cover [/.do] + (n.= (inc sample) + (||> (/.push sample) + (/.push (|>> (/.push false))) + (/.push |inc|) + /.do /.while))) + (_.cover [/.compose] + (n.= (inc (inc sample)) + (||> (/.push sample) + (/.push |inc|) + (/.push |inc|) + /.compose + /.call))) + (_.cover [/.curry] + (n.= (n.+ sample sample) + (||> (/.push sample) + (/.push sample) + (/.push (/.apply/2 n.+)) + /.curry + /.call))) + (_.cover [/.when] + (n.= (if choice + (inc sample) + sample) + (||> (/.push sample) + (/.push choice) + (/.push (/.apply/1 inc)) + /.when))) + (_.cover [/.?] + (n.= (if choice + (inc sample) + (dec sample)) + (||> (/.push choice) + (/.push (inc sample)) + (/.push (dec sample)) + /.?))) ))) (word: square @@ -219,14 +219,14 @@ Test (do random.monad [sample random.nat] - (_.test (%.name (name-of /.word:)) - (n.= (n.* sample sample) - (||> (/.push sample) - ..square))))) + (_.cover [/.word:] + (n.= (n.* sample sample) + (||> (/.push sample) + ..square))))) (def: #export test Test - (<| (_.context (name.module (name-of /._))) + (<| (_.covering /._) ($_ _.and ..stack-shuffling ..numerical diff --git a/stdlib/source/test/lux/control/try.lux b/stdlib/source/test/lux/control/try.lux index ef090c1a9..997a810ba 100644 --- a/stdlib/source/test/lux/control/try.lux +++ b/stdlib/source/test/lux/control/try.lux @@ -72,6 +72,14 @@ (_.cover [/.assume] (n.= expected (/.assume (/.succeed expected)))) + (_.cover [/.from-maybe] + (case [(/.from-maybe (#.Some expected)) + (/.from-maybe #.None)] + [(#/.Success actual) (#/.Failure _)] + (n.= expected actual) + + _ + false)) (_.cover [/.to-maybe] (case [(/.to-maybe (/.succeed expected)) (/.to-maybe (/.fail error))] @@ -86,7 +94,6 @@ (n.= alternative (/.default alternative (: (Try Nat) (/.fail error)))))) - (_.cover [/.with /.lift] (let [lift (/.lift io.monad)] (|> (do (/.with io.monad) |