aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--commands.md1
-rw-r--r--new-luxc/source/program.lux4
-rw-r--r--stdlib/source/lux/abstract/comonad.lux10
-rw-r--r--stdlib/source/lux/abstract/monad.lux10
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux149
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io/context.lux61
-rw-r--r--stdlib/source/program/compositor.lux4
-rw-r--r--stdlib/source/program/compositor/cli.lux6
-rw-r--r--stdlib/source/program/compositor/export.lux6
-rw-r--r--stdlib/source/program/compositor/import.lux62
-rw-r--r--stdlib/source/test/lux/abstract.lux21
-rw-r--r--stdlib/source/test/lux/abstract/monad/free.lux57
-rw-r--r--stdlib/source/test/lux/abstract/predicate.lux113
13 files changed, 346 insertions, 158 deletions
diff --git a/commands.md b/commands.md
index 542bf9932..f29b148e3 100644
--- a/commands.md
+++ b/commands.md
@@ -297,6 +297,7 @@ cd ~/lux/new-luxc/ && java -jar target/program.jar repl --source ~/lux/stdlib/so
```
cd ~/lux/new-luxc/ && time java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux
cd ~/lux/stdlib/ && lein clean && cd ~/lux/new-luxc/ && time java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux
+cd ~/lux/stdlib/ && lein clean && cd ~/lux/new-luxc/ && time java -jar target/program.jar build --source ~/lux/stdlib/source --library ~/lux/stdlib/target/library.tar --target ~/lux/stdlib/target --module test/lux
cd ~/lux/new-luxc/ && java -jar target/program.jar export --source ~/lux/stdlib/source --target ~/lux/stdlib/target
cd ~/lux/stdlib/target/ && java -jar program.jar
diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux
index 54f1437c7..e2cf047e9 100644
--- a/new-luxc/source/program.lux
+++ b/new-luxc/source/program.lux
@@ -150,8 +150,8 @@
(def: (target service)
(-> /cli.Service /cli.Target)
(case service
- (^or (#/cli.Compilation [sources target module])
- (#/cli.Interpretation [sources target module])
+ (^or (#/cli.Compilation [sources libraries target module])
+ (#/cli.Interpretation [sources libraries target module])
(#/cli.Export [sources target]))
target))
diff --git a/stdlib/source/lux/abstract/comonad.lux b/stdlib/source/lux/abstract/comonad.lux
index 988d7c255..874b96913 100644
--- a/stdlib/source/lux/abstract/comonad.lux
+++ b/stdlib/source/lux/abstract/comonad.lux
@@ -6,7 +6,7 @@
[collection
["." list ("#@." fold)]]]]
[//
- ["." functor (#+ Functor)]])
+ [functor (#+ Functor)]])
(signature: #export (CoMonad w)
{#.doc (doc "CoMonads are the opposite/complement to monads."
@@ -66,17 +66,13 @@
(#.Some name)
(let [name [_cursor (#.Identifier ["" name])]]
(` ({(~ name)
- ({{#..&functor {#functor.map (~ g!map)}
- #..unwrap (~' unwrap)
- #..split (~ g!split)}
+ ({[(~ g!map) (~' unwrap) (~ g!split)]
(~ body')}
(~ name))}
(~ comonad))))
#.None
- (` ({{#..&functor {#functor.map (~ g!map)}
- #..unwrap (~' unwrap)
- #..split (~ g!split)}
+ (` ({[(~ g!map) (~' unwrap) (~ g!split)]
(~ body')}
(~ comonad)))))]))
(#.Left "'be' bindings must have an even number of parts."))
diff --git a/stdlib/source/lux/abstract/monad.lux b/stdlib/source/lux/abstract/monad.lux
index 12f75e9ac..4c03e937c 100644
--- a/stdlib/source/lux/abstract/monad.lux
+++ b/stdlib/source/lux/abstract/monad.lux
@@ -1,7 +1,7 @@
(.module:
[lux #*]
[//
- ["." functor (#+ Functor)]])
+ [functor (#+ Functor)]])
(def: (list@fold f init xs)
(All [a b]
@@ -92,17 +92,13 @@
(#.Some name)
(let [name [_cursor (#.Identifier ["" name])]]
(` ({(~ name)
- ({{#..&functor {#functor.map (~ g!map)}
- #..wrap (~' wrap)
- #..join (~ g!join)}
+ ({[(~ g!map) (~' wrap) (~ g!join)]
(~ body')}
(~ name))}
(~ monad))))
#.None
- (` ({{#..&functor {#functor.map (~ g!map)}
- #..wrap (~' wrap)
- #..join (~ g!join)}
+ (` ({[(~ g!map) (~' wrap) (~ g!join)]
(~ body')}
(~ monad)))))]))
(#.Left "'do' bindings must have an even number of parts."))
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 5f117325c..7813ba799 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -52,8 +52,9 @@
["ioW" archive]]]]]
[program
[compositor
- ["." cli (#+ Compilation)]
- ["." static (#+ Static)]]])
+ ["." cli (#+ Compilation Library)]
+ ["." static (#+ Static)]
+ ["." import]]])
(type: #export (Platform anchor expression directive)
{#&file-system (file.System Promise)
@@ -351,85 +352,85 @@
try.assume
product.left))
- (def: #export (compile static expander platform compilation context)
+ (def: #export (compile libraries static expander platform compilation context)
(All [<type-vars>]
- (-> Static Expander <Platform> Compilation <Context> <Return>))
- (let [[compilation-sources compilation-target compilation-module] compilation
+ (-> (List Library) Static Expander <Platform> Compilation <Context> <Return>))
+ (let [[compilation-sources compilation-libraries compilation-target compilation-module] compilation
base-compiler (:share [<type-vars>]
{<Context>
context}
{(///.Compiler <State+> .Module Any)
(:assume
- ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))})
- parallel-compiler (..parallel
- context
- (function (_ import! module-id [archive state] module)
- (do (try.with promise.monad)
- [#let [state (..set-current-module module state)]
- input (context.read (get@ #&file-system platform)
- compilation-sources
- (get@ #static.host-module-extension static)
- module)]
- (loop [[archive state] [archive state]
- compilation (base-compiler (:coerce ///.Input input))
- all-dependencies (: (List Module)
- (list))]
- (do {@ (try.with promise.monad)}
- [#let [new-dependencies (get@ #///.dependencies compilation)
- all-dependencies (list@compose new-dependencies all-dependencies)
- continue! (:share [<type-vars>]
- {<Platform>
- platform}
- {(-> <Context> (///.Compilation <State+> .Module Any) (List Module)
- (Action [Archive <State+>]))
- (:assume
- recur)})]
- [archive state] (case new-dependencies
- #.Nil
- (wrap [archive state])
+ ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))})]
+ (do (try.with promise.monad)
+ [libraries (import.import (get@ #&file-system platform) compilation-libraries)
+ #let [parallel-compiler (..parallel
+ context
+ (function (_ import! module-id [archive state] module)
+ (do (try.with promise.monad)
+ [#let [state (..set-current-module module state)]
+ input (context.read (get@ #&file-system platform)
+ libraries
+ compilation-sources
+ (get@ #static.host-module-extension static)
+ module)]
+ (loop [[archive state] [archive state]
+ compilation (base-compiler (:coerce ///.Input input))
+ all-dependencies (: (List Module)
+ (list))]
+ (do {@ (try.with promise.monad)}
+ [#let [new-dependencies (get@ #///.dependencies compilation)
+ all-dependencies (list@compose new-dependencies all-dependencies)
+ continue! (:share [<type-vars>]
+ {<Platform>
+ platform}
+ {(-> <Context> (///.Compilation <State+> .Module Any) (List Module)
+ (Action [Archive <State+>]))
+ (:assume
+ recur)})]
+ [archive state] (case new-dependencies
+ #.Nil
+ (wrap [archive state])
- (#.Cons _)
- (do @
- [archive,document+ (|> new-dependencies
- (list@map import!)
- (monad.seq ..monad))
- #let [archive (|> archive,document+
- (list@map product.left)
- (list@fold archive.merge archive))]]
- (wrap [archive (try.assume
- (..updated-state archive state))])))]
- (case ((get@ #///.process compilation)
- ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP.
- ## TODO: The context shouldn't need to be re-set either.
- (|> (///directive.set-current-module module)
- (///phase.run' state)
- try.assume
- product.left)
- archive)
- (#try.Success [state more|done])
- (case more|done
- (#.Left more)
- (continue! [archive state] more all-dependencies)
+ (#.Cons _)
+ (do @
+ [archive,document+ (|> new-dependencies
+ (list@map import!)
+ (monad.seq ..monad))
+ #let [archive (|> archive,document+
+ (list@map product.left)
+ (list@fold archive.merge archive))]]
+ (wrap [archive (try.assume
+ (..updated-state archive state))])))]
+ (case ((get@ #///.process compilation)
+ ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP.
+ ## TODO: The context shouldn't need to be re-set either.
+ (|> (///directive.set-current-module module)
+ (///phase.run' state)
+ try.assume
+ product.left)
+ archive)
+ (#try.Success [state more|done])
+ (case more|done
+ (#.Left more)
+ (continue! [archive state] more all-dependencies)
- (#.Right [[descriptor document] output])
- (do (try.with promise.monad)
- [#let [_ (log! (..module-compilation-log state))
- descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)]
- _ (..cache-module static platform module-id [[descriptor document] output])]
- (case (archive.add module [descriptor document] archive)
- (#try.Success archive)
- (wrap [archive
- (..with-reset-log state)])
-
- (#try.Failure error)
- (promise@wrap (#try.Failure error)))))
+ (#.Right [[descriptor document] output])
+ (do (try.with promise.monad)
+ [#let [_ (log! (..module-compilation-log state))
+ descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)]
+ _ (..cache-module static platform module-id [[descriptor document] output])]
+ (case (archive.add module [descriptor document] archive)
+ (#try.Success archive)
+ (wrap [archive
+ (..with-reset-log state)])
+
+ (#try.Failure error)
+ (promise@wrap (#try.Failure error)))))
- (#try.Failure error)
- (do (try.with promise.monad)
- [_ (ioW.freeze (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static) archive)]
- (promise@wrap (#try.Failure error))))
- ))
- )))]
- (parallel-compiler compilation-module)
- ))
+ (#try.Failure error)
+ (do (try.with promise.monad)
+ [_ (ioW.freeze (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static) archive)]
+ (promise@wrap (#try.Failure error)))))))))]]
+ (parallel-compiler compilation-module))))
))
diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux
index 574b24290..1dceaaba6 100644
--- a/stdlib/source/lux/tool/compiler/meta/io/context.lux
+++ b/stdlib/source/lux/tool/compiler/meta/io/context.lux
@@ -6,7 +6,7 @@
["." monad (#+ Monad do)]]
[control
["." try (#+ Try)]
- ["." exception (#+ Exception exception:)]
+ ["." exception (#+ exception:)]
[security
["!" capability]]
[concurrency
@@ -20,6 +20,9 @@
["." dictionary (#+ Dictionary)]]]
[world
["." file (#+ Path File)]]]
+ [program
+ [compositor
+ [import (#+ Import)]]]
["." // (#+ Context Code)
["/#" // #_
[archive
@@ -70,26 +73,60 @@
(-> Extension Extension)
(format partial-host-extension ..lux-extension))
-(def: #export (find-any-source-file system contexts partial-host-extension module)
- (-> (file.System Promise) (List Context) Extension Module
- (Promise (Try [Path (File Promise)])))
+(def: (find-local-source-file system import contexts partial-host-extension module)
+ (-> (file.System Promise) Import (List Context) Extension Module
+ (Promise (Try [Path Binary])))
+ ## Preference is explicitly being given to Lux files that have a host extension.
+ ## Normal Lux files (i.e. without a host extension) are then picked as fallback files.
+ (do {@ promise.monad}
+ [outcome (..find-source-file system contexts module (..full-host-extension partial-host-extension))]
+ (case outcome
+ (#try.Success [path file])
+ (do (try.with @)
+ [data (!.use (:: file content) [])]
+ (wrap [path data]))
+
+ (#try.Failure _)
+ (do (try.with @)
+ [[path file] (..find-source-file system contexts module ..lux-extension)
+ data (!.use (:: file content) [])]
+ (wrap [path data])))))
+
+(def: (find-library-source-file import partial-host-extension module)
+ (-> Import Extension Module (Try [Path Binary]))
+ (let [path (format module (..full-host-extension partial-host-extension))]
+ (case (dictionary.get path import)
+ (#.Some data)
+ (#try.Success [path data])
+
+ #.None
+ (let [path (format module ..lux-extension)]
+ (case (dictionary.get path import)
+ (#.Some data)
+ (#try.Success [path data])
+
+ #.None
+ (exception.throw ..cannot-find-module [module]))))))
+
+(def: (find-any-source-file system import contexts partial-host-extension module)
+ (-> (file.System Promise) Import (List Context) Extension Module
+ (Promise (Try [Path Binary])))
## Preference is explicitly being given to Lux files that have a host extension.
## Normal Lux files (i.e. without a host extension) are then picked as fallback files.
- (do promise.monad
- [outcome (find-source-file system contexts module (..full-host-extension partial-host-extension))]
+ (do {@ promise.monad}
+ [outcome (find-local-source-file system import contexts partial-host-extension module)]
(case outcome
- (#try.Success output)
+ (#try.Success [path data])
(wrap outcome)
(#try.Failure _)
- (find-source-file system contexts module ..lux-extension))))
+ (wrap (..find-library-source-file import partial-host-extension module)))))
-(def: #export (read system contexts partial-host-extension module)
- (-> (file.System Promise) (List Context) Extension Module
+(def: #export (read system import contexts partial-host-extension module)
+ (-> (file.System Promise) Import (List Context) Extension Module
(Promise (Try Input)))
(do (try.with promise.monad)
- [[path file] (..find-any-source-file system contexts partial-host-extension module)
- binary (!.use (:: file content) [])]
+ [[path binary] (..find-any-source-file system import contexts partial-host-extension module)]
(case (encoding.from-utf8 binary)
(#try.Success code)
(wrap {#////.module module
diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux
index d431198fa..63a73260d 100644
--- a/stdlib/source/program/compositor.lux
+++ b/stdlib/source/program/compositor.lux
@@ -94,7 +94,7 @@
(#/cli.Compilation compilation)
(<| (or-crash! "Compilation failed:")
(do (try.with promise.monad)
- [#let [[compilation-sources compilation-target compilation-module] compilation]
+ [#let [[compilation-sources compilation-libraries compilation-target compilation-module] compilation]
[state archive] (:share [<parameters>]
{(Platform <parameters>)
platform}
@@ -105,7 +105,7 @@
{(Platform <parameters>)
platform}
{(Promise (Try [Archive (directive.State+ <parameters>)]))
- (:assume (platform.compile static expander platform compilation [archive state]))})
+ (:assume (platform.compile compilation-libraries static expander platform compilation [archive state]))})
_ (ioW.freeze (get@ #platform.&file-system platform) (get@ #/static.host static) (get@ #/static.target static) archive)]
(wrap (log! "Compilation complete!"))))
diff --git a/stdlib/source/program/compositor/cli.lux b/stdlib/source/program/compositor/cli.lux
index 940665680..e0bcd6e00 100644
--- a/stdlib/source/program/compositor/cli.lux
+++ b/stdlib/source/program/compositor/cli.lux
@@ -12,10 +12,11 @@
[file (#+ Path)]]])
(type: #export Source Path)
+(type: #export Library Path)
(type: #export Target Path)
(type: #export Compilation
- [(List Source) Target Module])
+ [(List Source) (List Library) Target Module])
(type: #export Export
[(List Source) Target])
@@ -31,6 +32,7 @@
(cli.named <long> cli.any))]
[source "--source" Source]
+ [library "--library" Library]
[target "--target" Target]
[module "--module" Module]
)
@@ -41,11 +43,13 @@
(<>.after (cli.this "build")
($_ <>.and
(<>.some ..source)
+ (<>.some ..library)
..target
..module))
(<>.after (cli.this "repl")
($_ <>.and
(<>.some ..source)
+ (<>.some ..library)
..target
..module))
(<>.after (cli.this "export")
diff --git a/stdlib/source/program/compositor/export.lux b/stdlib/source/program/compositor/export.lux
index 6e364800f..f6a78ed78 100644
--- a/stdlib/source/program/compositor/export.lux
+++ b/stdlib/source/program/compositor/export.lux
@@ -9,7 +9,7 @@
[security
["!" capability]]]
[data
- [text
+ ["." text
["%" format (#+ format)]]
[collection
["." dictionary]
@@ -48,7 +48,9 @@
(monad.map try.monad
(function (_ [path source-code])
(do try.monad
- [path (tar.path path)
+ [path (|> path
+ (text.replace-all (:: system separator) .module-separator)
+ tar.path)
source-code (tar.content source-code)]
(wrap (#tar.Normal [path
(instant.from-millis +0)
diff --git a/stdlib/source/program/compositor/import.lux b/stdlib/source/program/compositor/import.lux
new file mode 100644
index 000000000..2e53e0976
--- /dev/null
+++ b/stdlib/source/program/compositor/import.lux
@@ -0,0 +1,62 @@
+(.module:
+ [lux #*
+ [abstract
+ ["." monad (#+ Monad do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ [concurrency
+ ["." promise (#+ Promise) ("#@." monad)]]
+ [security
+ ["!" capability]]
+ ["<>" parser
+ ["<b>" binary]]]
+ [data
+ [binary (#+ Binary)]
+ ["." text]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." row]]
+ [format
+ ["." tar]]]
+ [world
+ ["." file (#+ Path File)]]]
+ [//
+ [cli (#+ Library)]])
+
+(def: Action
+ (type (All [a] (Promise (Try a)))))
+
+(exception: #export useless-tar-entry)
+
+(type: #export Import
+ (Dictionary Path Binary))
+
+(def: (import-library system library import)
+ (-> (file.System Promise) Library Import (Action Import))
+ (do (try.with promise.monad)
+ [library (: (Action (File Promise))
+ (!.use (:: system file) [library]))
+ binary (!.use (:: library content) [])]
+ (promise@wrap
+ (do {@ try.monad}
+ [tar (<b>.run tar.parser binary)]
+ (monad.fold @ (function (_ entry import)
+ (case entry
+ (#tar.Normal [path instant mode ownership content])
+ (dictionary.try-put (tar.from-path path)
+ (tar.data content)
+ import)
+
+ _
+ (exception.throw ..useless-tar-entry [])))
+ import
+ (row.to-list tar))))))
+
+(def: #export (import system libraries)
+ (-> (file.System Promise) (List Library) (Action Import))
+ (monad.fold (: (Monad Action)
+ (try.with promise.monad))
+ (..import-library system)
+ (dictionary.new text.hash)
+ libraries))
diff --git a/stdlib/source/test/lux/abstract.lux b/stdlib/source/test/lux/abstract.lux
index aa93df86f..12c3625b3 100644
--- a/stdlib/source/test/lux/abstract.lux
+++ b/stdlib/source/test/lux/abstract.lux
@@ -8,21 +8,28 @@
["#." enum]
["#." equivalence]
["#." fold]
- ["#." functor]
+ ["#." functor
+ ["#/." contravariant]]
["#." hash]
["#." interval]
- ["#." monad]
+ ["#." monad
+ ["#/." free]]
["#." monoid]
["#." order]
- ["#." predicate]
- [functor
- ["#." contravariant]]])
+ ["#." predicate]])
(def: functor
Test
($_ _.and
/functor.test
- /contravariant.test
+ /functor/contravariant.test
+ ))
+
+(def: monad
+ Test
+ ($_ _.and
+ /monad.test
+ /monad/free.test
))
(def: #export test
@@ -37,7 +44,7 @@
..functor
/hash.test
/interval.test
- /monad.test
+ ..monad
/monoid.test
/order.test
/predicate.test
diff --git a/stdlib/source/test/lux/abstract/monad/free.lux b/stdlib/source/test/lux/abstract/monad/free.lux
new file mode 100644
index 000000000..7241dc8b9
--- /dev/null
+++ b/stdlib/source/test/lux/abstract/monad/free.lux
@@ -0,0 +1,57 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ [monad (#+ Monad do)]
+ {[0 #test]
+ [/
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]}]
+ [data
+ [collection
+ ["." list ("#@." functor)]]]
+ [math
+ ["." random]]]
+ {1
+ ["." /]})
+
+(def: injection
+ (Injection (/.Free List))
+ (|>> #/.Pure))
+
+(def: (interpret free)
+ (All [a] (-> (/.Free List a) (List a)))
+ (case free
+ (#/.Pure value)
+ (list value)
+
+ (#/.Effect effect)
+ (|> effect
+ (list@map interpret)
+ list.concat)))
+
+(def: comparison
+ (Comparison (/.Free List))
+ (function (_ == left right)
+ (:: (list.equivalence ==) =
+ (..interpret left)
+ (..interpret right))))
+
+(def: #export test
+ Test
+ (<| (_.covering /._)
+ (_.with-cover [/.Free])
+ ($_ _.and
+ (_.with-cover [/.functor]
+ ($functor.spec ..injection ..comparison (: (Functor (/.Free List))
+ (/.functor list.functor))))
+ (_.with-cover [/.apply]
+ ($apply.spec ..injection ..comparison (: (Apply (/.Free List))
+ (/.apply list.functor))))
+ (_.with-cover [/.monad]
+ ($monad.spec ..injection ..comparison (: (Monad (/.Free List))
+ (/.monad list.functor))))
+ )))
diff --git a/stdlib/source/test/lux/abstract/predicate.lux b/stdlib/source/test/lux/abstract/predicate.lux
index 3831ac0fb..1a0d457db 100644
--- a/stdlib/source/test/lux/abstract/predicate.lux
+++ b/stdlib/source/test/lux/abstract/predicate.lux
@@ -3,21 +3,25 @@
["_" test (#+ Test)]
[abstract
[equivalence (#+ Equivalence)]
- [monad (#+ do)]]
+ [monad (#+ do)]
+ {[0 #spec]
+ [/
+ [functor
+ ["." contravariant]]]}]
[control
["." function]]
[data
["." bit ("#@." equivalence)]
- [text
- ["%" format (#+ format)]]
[number
- ["n" nat]]]
+ ["n" nat]]
+ [collection
+ ["." list]]]
[math
- ["r" random (#+ Random)]]]
+ ["." random (#+ Random)]]]
["." // #_
["#." monoid]]
{1
- ["." / (#+ Predicate)]})
+ ["." /]})
(def: (multiple? factor)
(-> Nat (/.Predicate Nat))
@@ -27,41 +31,62 @@
(def: #export test
Test
- (let [/2? (multiple? 2)
- /3? (multiple? 3)]
- (<| (_.context (%.name (name-of /.Predicate)))
- (do {@ r.monad}
- [sample r.nat])
- ($_ _.and
- (_.test (%.name (name-of /.none))
- (bit@= false (/.none sample)))
- (_.test (%.name (name-of /.all))
- (bit@= true (/.all sample)))
- (_.test (%.name (name-of /.unite))
- (bit@= (/.all sample)
- ((/.unite /.none /.all) sample)))
- (_.test (%.name (name-of /.intersect))
- (bit@= (/.none sample)
- ((/.intersect /.none /.all) sample)))
- (_.test (%.name (name-of /.complement))
- (and (not (bit@= (/.none sample)
- ((/.complement /.none) sample)))
- (not (bit@= (/.all sample)
- ((/.complement /.all) sample)))))
- (_.test (%.name (name-of /.difference))
- (bit@= (and (/2? sample)
- (not (/3? sample)))
- ((/.difference /3? /2?) sample)))
- (let [equivalence (: (Equivalence (/.Predicate Nat))
- (structure
- (def: (= left right)
- (bit@= (left sample)
- (right sample)))))
- generator (: (Random (/.Predicate Nat))
- (|> r.nat
- (r.filter (|>> (n.= 0) not))
- (:: @ map multiple?)))]
- ($_ _.and
- (//monoid.spec equivalence /.union generator)
- (//monoid.spec equivalence /.intersection generator)))
- ))))
+ (<| (_.covering /._)
+ (do {@ random.monad}
+ [sample random.nat
+ samples (random.list 10 random.nat)
+ #let [equivalence (: (Equivalence (/.Predicate Nat))
+ (structure
+ (def: (= left right)
+ (bit@= (left sample)
+ (right sample)))))]])
+ (_.with-cover [/.Predicate])
+ ($_ _.and
+ (_.with-cover [/.functor]
+ (contravariant.spec equivalence (multiple? 2) /.functor))
+ (let [generator (: (Random (/.Predicate Nat))
+ (|> random.nat
+ (random.filter (|>> (n.= 0) not))
+ (:: @ map multiple?)))]
+ ($_ _.and
+ (_.with-cover [/.union]
+ (//monoid.spec equivalence /.union generator))
+ (_.with-cover [/.intersection]
+ (//monoid.spec equivalence /.intersection generator))))
+
+ (_.cover [/.none]
+ (bit@= false (/.none sample)))
+ (_.cover [/.all]
+ (bit@= true (/.all sample)))
+ (_.cover [/.unite]
+ (bit@= (/.all sample)
+ ((/.unite /.none /.all) sample)))
+ (_.cover [/.intersect]
+ (bit@= (/.none sample)
+ ((/.intersect /.none /.all) sample)))
+ (_.cover [/.complement]
+ (and (not (bit@= (/.none sample)
+ ((/.complement /.none) sample)))
+ (not (bit@= (/.all sample)
+ ((/.complement /.all) sample)))))
+ (_.cover [/.difference]
+ (let [/2? (multiple? 2)
+ /3? (multiple? 3)]
+ (bit@= (and (/2? sample)
+ (not (/3? sample)))
+ ((/.difference /3? /2?) sample))))
+ (_.cover [/.rec]
+ (let [even? (multiple? 2)
+ any-even? (: (/.Predicate (List Nat))
+ (/.rec (function (_ recur)
+ (function (_ values)
+ (case values
+ #.Nil
+ false
+
+ (#.Cons head tail)
+ (or (even? head)
+ (recur tail)))))))]
+ (bit@= (list.any? even? samples)
+ (any-even? samples))))
+ )))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-02 19:52:17 +0000