From 8d9fd8b34f8716be7fa1059eb9761330d9667753 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sat, 9 May 2020 02:12:56 -0400
Subject: Including runtime machinery in the cache.
---
stdlib/source/lux/abstract/functor.lux | 22 +-
stdlib/source/lux/control/exception.lux | 36 +--
stdlib/source/lux/control/security/policy.lux | 4 +-
stdlib/source/lux/data/collection/tree.lux | 20 +-
stdlib/source/lux/target/jvm/loader.lux | 25 +-
stdlib/source/lux/test.lux | 88 +++++--
.../source/lux/tool/compiler/default/platform.lux | 80 +++---
.../language/lux/phase/analysis/module.lux | 36 +--
stdlib/source/lux/tool/compiler/meta/archive.lux | 10 +-
.../source/lux/tool/compiler/meta/io/archive.lux | 47 ++--
stdlib/source/program/compositor.lux | 13 +-
stdlib/source/test/lux/abstract/functor.lux | 84 +++++--
stdlib/source/test/lux/control/concatenative.lux | 272 ++++++++++-----------
stdlib/source/test/lux/control/try.lux | 9 +-
14 files changed, 454 insertions(+), 292 deletions(-)
(limited to 'stdlib')
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) (All [a] (-> (Equivalence a) (Equivalence (Tree a))))
+(structure: #export (equivalence Equivalence)
+ (All [a] (-> (Equivalence a) (Equivalence (Tree a))))
+
(def: (= tx ty)
(and (:: Equivalence = (get@ #value tx) (get@ #value ty))
(:: (list.equivalence (equivalence Equivalence)) = (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
["" 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 (.tuple (<>.many .any))}
- condition)
- (let [coverage (list@map (function (_ definition)
- (` ((~! ..reference) (~ definition))))
- coverage)]
- (wrap (list (` ((~! ..cover')
- (: (.List .Name)
- (.list (~+ coverage)))
- (~ condition)))))))
+(template [ ]
+ [(syntax: #export ( {coverage (.tuple (<>.many .any))}
+ condition)
+ (let [coverage (list@map (function (_ definition)
+ (` ((~! ..reference) (~ definition))))
+ coverage)]
+ (wrap (list (` ((~! )
+ (: (.List .Name)
+ (.list (~+ coverage)))
+ (~ condition)))))))]
+
+ [claim ..claim']
+ [cover ..cover']
+ )
(syntax: #export (with-cover {coverage (.tuple (<>.many .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
- (-> Host Path Path archive.ID Text [[Descriptor (Document Any)] Output]
+ (-> 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
- (-> (///generation.Operation anchor expression directive Any)))
- (get@ #runtime))
+ (-> (///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
+ (-> .Lux Archive
+ (///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
@@ -115,7 +151,7 @@
(///directive.Bundle anchor expression directive)
(-> expression directive)
Extender
- (Promise (Try [ Archive (Buffer directive)]))))
+ (Promise (Try [ 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
@@ -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 []
[(exception: #export ( {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 []
- {(Platform )
- platform}
- {(Promise (Try [(directive.State+ )
- 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 []
+ {(Platform )
+ platform}
+ {(Promise (Try [(directive.State+ )
+ Archive]))
+ (platform.initialize extension target host (get@ #/cli.module configuration) expander host-analysis platform generation-bundle host-directive-bundle program extender)})
[archive state] (:share []
{(Platform )
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 [ ]
- [(_.test (%.name (name-of ))
- ((sum.equivalence n.= n.=)
- ( sample)
- (||> (/.push sample)
- )))]
+ [(_.cover []
+ ((sum.equivalence n.= n.=)
+ ( sample)
+ (||> (/.push sample)
+ )))]
[/.||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 <=> )
@@ -102,19 +102,19 @@
subject ]
(`` ($_ _.and
(~~ (template [ ]
- [(_.test (%.name (name-of ))
- (<=> ( parameter subject)
- (||> (/.push subject)
- (/.push parameter)
- )))]
+ [(_.cover []
+ (<=> ( parameter subject)
+ (||> (/.push subject)
+ (/.push parameter)
+ )))]
'))
(~~ (template [ ]
- [(_.test (%.name (name-of ))
- (bit@= ( parameter subject)
- (||> (/.push subject)
- (/.push parameter)
- )))]
+ [(_.cover []
+ (bit@= ( parameter subject)
+ (||> (/.push subject)
+ (/.push parameter)
+ )))]
'))
))))))
@@ -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)
--
cgit v1.2.3