From ce7614f00a134cb61b4a6f88cfea33461a7bf478 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Wed, 7 Oct 2020 17:00:57 -0400
Subject: Test imports for circular dependencies.
---
commands.md | 6 +
stdlib/project.clj | 3 +-
stdlib/source/lux/data/env.lux | 25 -
stdlib/source/lux/data/identity.lux | 19 +-
stdlib/source/lux/target/jvm/bytecode.lux | 76 ++-
.../source/lux/tool/compiler/default/platform.lux | 183 ++++--
.../lux/tool/compiler/language/lux/directive.lux | 2 +-
stdlib/source/program/aedifex/artifact.lux | 9 +
stdlib/source/program/aedifex/dependency.lux | 8 +
stdlib/source/program/aedifex/format.lux | 153 +++++
stdlib/source/program/aedifex/parser.lux | 23 +-
stdlib/source/program/aedifex/profile.lux | 89 ++-
stdlib/source/program/aedifex/project.lux | 10 +-
stdlib/source/spec/lux/abstract/comonad.lux | 61 ++
stdlib/source/test/aedifex.lux | 21 +
stdlib/source/test/aedifex/parser.lux | 212 +++++++
stdlib/source/test/lux/data/identity.lux | 26 +-
stdlib/source/test/lux/target/jvm.lux | 621 +++++++++++----------
18 files changed, 1117 insertions(+), 430 deletions(-)
delete mode 100644 stdlib/source/lux/data/env.lux
create mode 100644 stdlib/source/program/aedifex/format.lux
create mode 100644 stdlib/source/spec/lux/abstract/comonad.lux
create mode 100644 stdlib/source/test/aedifex.lux
create mode 100644 stdlib/source/test/aedifex/parser.lux
diff --git a/commands.md b/commands.md
index 0e9fefbd1..617772bf3 100644
--- a/commands.md
+++ b/commands.md
@@ -90,6 +90,12 @@ cd ~/lux/stdlib/ && lein clean && lein with-profile scriptum lux auto build
cd ~/lux/stdlib/ && lein clean && lein with-profile aedifex lux auto build
```
+## Test
+
+```
+cd ~/lux/stdlib/ && lein clean && lein with-profile aedifex lux auto test
+```
+
---
# Licentia: License maker
diff --git a/stdlib/project.clj b/stdlib/project.clj
index 8a79475c2..dcaec7c4c 100644
--- a/stdlib/project.clj
+++ b/stdlib/project.clj
@@ -26,7 +26,8 @@
:lux {:test "test/lux"}}
:aedifex {:description "A build system/tool made exclusively for Lux."
:dependencies []
- :lux {:program "program/aedifex"}}
+ :lux {:program "program/aedifex"
+ :test "test/aedifex"}}
:scriptum {:description "A documentation generator for Lux code."
:dependencies []
:lux {:program "program/scriptum"}}
diff --git a/stdlib/source/lux/data/env.lux b/stdlib/source/lux/data/env.lux
deleted file mode 100644
index 7e4265e6a..000000000
--- a/stdlib/source/lux/data/env.lux
+++ /dev/null
@@ -1,25 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [functor (#+ Functor)]
- comonad]])
-
-(type: #export (Env e a)
- {#env e
- #value a})
-
-(structure: #export functor (All [e] (Functor (Env e)))
- (def: (map f fa)
- (update@ #value f fa)))
-
-(structure: #export comonad (All [e] (CoMonad (Env e)))
- (def: &functor ..functor)
-
- (def: unwrap (get@ #value))
-
- (def: (split wa)
- (set@ #value wa wa)))
-
-(def: #export (local change env)
- (All [e a] (-> (-> e e) (Env e a) (Env e a)))
- (update@ #env change env))
diff --git a/stdlib/source/lux/data/identity.lux b/stdlib/source/lux/data/identity.lux
index 412103987..ce0476d8a 100644
--- a/stdlib/source/lux/data/identity.lux
+++ b/stdlib/source/lux/data/identity.lux
@@ -11,20 +11,27 @@
(type: #export (Identity a)
a)
-(structure: #export functor (Functor Identity)
+(structure: #export functor
+ (Functor Identity)
+
(def: map function.identity))
-(structure: #export apply (Apply Identity)
+(structure: #export apply
+ (Apply Identity)
+
(def: &functor ..functor)
- (def: (apply ff fa)
- (ff fa)))
+ (def: (apply ff fa) (ff fa)))
-(structure: #export monad (Monad Identity)
+(structure: #export monad
+ (Monad Identity)
+
(def: &functor ..functor)
(def: wrap function.identity)
(def: join function.identity))
-(structure: #export comonad (CoMonad Identity)
+(structure: #export comonad
+ (CoMonad Identity)
+
(def: &functor ..functor)
(def: unwrap function.identity)
(def: split function.identity))
diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux
index e1c19c55d..c46b5bf1f 100644
--- a/stdlib/source/lux/target/jvm/bytecode.lux
+++ b/stdlib/source/lux/target/jvm/bytecode.lux
@@ -456,7 +456,11 @@
(#try.Failure _)
(..bytecode $0 $1 @_ _.ldc-w/string [index]))))
-(import: #long java/lang/Float)
+(import: #long java/lang/Float
+ (#static floatToRawIntBits #manual [float] int))
+
+(import: #long java/lang/Double
+ (#static doubleToRawLongBits #manual [double] int))
(template [<name> <type> <constructor> <constant> <wide> <to-lux> <specializations>]
[(def: #export (<name> value)
@@ -484,13 +488,42 @@
[+3 _.iconst-3]
[+4 _.iconst-4]
[+5 _.iconst-5])]
- [float java/lang/Float //constant.float //constant/pool.float _.ldc-w/float
- (<| (:coerce Frac) host.float-to-double)
- ([+0.0 _.fconst-0]
- [+1.0 _.fconst-1]
- [+2.0 _.fconst-2])]
)
+(def: (arbitrary-float value)
+ (-> java/lang/Float (Bytecode Any))
+ (do ..monad
+ [index (..lift (//constant/pool.float (//constant.float value)))]
+ (case (|> index //index.value //unsigned.value //unsigned.u1)
+ (#try.Success index)
+ (..bytecode $0 $1 @_ _.ldc [index])
+
+ (#try.Failure _)
+ (..bytecode $0 $1 @_ _.ldc-w/float [index]))))
+
+(def: float-bits
+ (-> java/lang/Float Int)
+ (|>> java/lang/Float::floatToRawIntBits
+ host.int-to-long
+ (:coerce Int)))
+
+(def: negative-zero-float-bits
+ (|> -0.0 host.double-to-float ..float-bits))
+
+(def: #export (float value)
+ (-> java/lang/Float (Bytecode Any))
+ (if (i.= ..negative-zero-float-bits
+ (..float-bits value))
+ (..arbitrary-float value)
+ (case (|> value host.float-to-double (:coerce Frac))
+ (^template [<special> <instruction>]
+ <special> (..bytecode $0 $1 @_ <instruction> []))
+ ([+0.0 _.fconst-0]
+ [+1.0 _.fconst-1]
+ [+2.0 _.fconst-2])
+
+ _ (..arbitrary-float value))))
+
(template [<name> <type> <constructor> <constant> <wide> <to-lux> <specializations>]
[(def: #export (<name> value)
(-> <type> (Bytecode Any))
@@ -507,12 +540,35 @@
(<|)
([+0 _.lconst-0]
[+1 _.lconst-1])]
- [double Frac //constant.double //constant/pool.double _.ldc2-w/double
- (<|)
- ([+0.0 _.dconst-0]
- [+1.0 _.dconst-1])]
)
+(def: (arbitrary-double value)
+ (-> java/lang/Double (Bytecode Any))
+ (do ..monad
+ [index (..lift (//constant/pool.double (//constant.double value)))]
+ (..bytecode $0 $2 @_ _.ldc2-w/double [index])))
+
+(def: double-bits
+ (-> java/lang/Double Int)
+ (|>> java/lang/Double::doubleToRawLongBits
+ (:coerce Int)))
+
+(def: negative-zero-double-bits
+ (..double-bits -0.0))
+
+(def: #export (double value)
+ (-> java/lang/Double (Bytecode Any))
+ (if (i.= ..negative-zero-double-bits
+ (..double-bits value))
+ (..arbitrary-double value)
+ (case value
+ (^template [<special> <instruction>]
+ <special> (..bytecode $0 $2 @_ <instruction> []))
+ ([+0.0 _.dconst-0]
+ [+1.0 _.dconst-1])
+
+ _ (..arbitrary-double value))))
+
(exception: #export (invalid-register {id Nat})
(exception.report
["ID" (%.nat id)]))
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 2d005d450..d15bec236 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -5,6 +5,7 @@
[abstract
["." monad (#+ Monad do)]]
[control
+ ["." function]
["." try (#+ Try)]
["." exception (#+ exception:)]
[concurrency
@@ -14,12 +15,13 @@
["." binary (#+ Binary)]
["." bit]
["." product]
+ ["." maybe]
["." text ("#@." equivalence)
["%" format (#+ format)]]
[collection
["." dictionary (#+ Dictionary)]
["." row (#+ Row) ("#@." fold)]
- ["." set]
+ ["." set (#+ Set)]
["." list ("#@." monoid functor fold)]]
[format
["_" binary (#+ Writer)]]]
@@ -240,12 +242,94 @@
#///generation.log]
row.empty))
+ (def: empty
+ (Set Module)
+ (set.new text.hash))
+
+ (type: Mapping
+ (Dictionary Module (Set Module)))
+
+ (type: Dependence
+ {#depends-on Mapping
+ #depended-by Mapping})
+
+ (def: independence
+ Dependence
+ (let [empty (dictionary.new text.hash)]
+ {#depends-on empty
+ #depended-by empty}))
+
+ (def: (depend module import dependence)
+ (-> Module Module Dependence Dependence)
+ (let [transitive-dependency (: (-> (-> Dependence Mapping) Module (Set Module))
+ (function (_ lens module)
+ (|> dependence
+ lens
+ (dictionary.get module)
+ (maybe.default ..empty))))
+ transitive-depends-on (transitive-dependency (get@ #depends-on) import)
+ transitive-depended-by (transitive-dependency (get@ #depended-by) module)
+ update-dependence (: (-> [Module (Set Module)] [Module (Set Module)]
+ (-> Mapping Mapping))
+ (function (_ [source forward] [target backward])
+ (function (_ mapping)
+ (let [with-dependence+transitives
+ (|> mapping
+ (dictionary.upsert source ..empty (set.add target))
+ (dictionary.update source (set.union forward)))]
+ (list@fold (function (_ previous)
+ (dictionary.upsert previous ..empty (set.add target)))
+ with-dependence+transitives
+ (set.to-list backward))))))]
+ (|> dependence
+ (update@ #depends-on
+ (update-dependence
+ [module transitive-depends-on]
+ [import transitive-depended-by]))
+ (update@ #depended-by
+ ((function.flip update-dependence)
+ [module transitive-depends-on]
+ [import transitive-depended-by])))))
+
+ (def: (circular-dependency? module import dependence)
+ (-> Module Module Dependence Bit)
+ (let [dependence? (: (-> Module (-> Dependence Mapping) Module Bit)
+ (function (_ from relationship to)
+ (let [targets (|> dependence
+ relationship
+ (dictionary.get from)
+ (maybe.default ..empty))]
+ (set.member? targets to))))]
+ (or (dependence? import (get@ #depends-on) module)
+ (dependence? module (get@ #depended-by) import))))
+
+ (exception: #export (module-cannot-import-itself {module Module})
+ (exception.report
+ ["Module" (%.text module)]))
+
+ (exception: #export (cannot-import-circular-dependency {importer Module}
+ {importee Module})
+ (exception.report
+ ["Importer" (%.text importer)]
+ ["importee" (%.text importee)]))
+
+ (def: (verify-dependencies importer importee dependence)
+ (-> Module Module Dependence (Try Any))
+ (cond (text@= importer importee)
+ (exception.throw ..module-cannot-import-itself [importer])
+
+ (..circular-dependency? importer importee dependence)
+ (exception.throw ..cannot-import-circular-dependency [importer importee])
+
+ ## else
+ (#try.Success [])))
+
(with-expansions [<Context> (as-is [Archive <State+>])
<Result> (as-is (Try <Context>))
<Return> (as-is (Promise <Result>))
<Signal> (as-is (Resolver <Result>))
<Pending> (as-is [<Return> <Signal>])
- <Importer> (as-is (-> Module <Return>))
+ <Importer> (as-is (-> Module Module <Return>))
<Compiler> (as-is (-> <Importer> archive.ID <Context> Module <Return>))]
(def: (parallel initial)
(All [<type-vars>]
@@ -256,9 +340,11 @@
{<Context>
initial}
{(Var (Dictionary Module <Pending>))
- (:assume (stm.var (dictionary.new text.hash)))})]
+ (:assume (stm.var (dictionary.new text.hash)))})
+ dependence (: (Var Dependence)
+ (stm.var ..independence))]
(function (_ compile)
- (function (import! module)
+ (function (import! importer module)
(do {@ promise.monad}
[[return signal] (:share [<type-vars>]
{<Context>
@@ -269,40 +355,52 @@
(:assume
(stm.commit
(do {@ stm.monad}
- [[archive state] (stm.read current)]
- (if (archive.archived? archive module)
- (wrap [(promise@wrap (#try.Success [archive state]))
+ [dependence (if (text@= archive.runtime-module importer)
+ (stm.read dependence)
+ (do @
+ [[_ dependence] (stm.update (..depend importer module) dependence)]
+ (wrap dependence)))]
+ (case (..verify-dependencies importer module dependence)
+ (#try.Failure error)
+ (wrap [(promise.resolved (#try.Failure error))
#.None])
+
+ (#try.Success _)
(do @
- [@pending (stm.read pending)]
- (case (dictionary.get module @pending)
- (#.Some [return signal])
- (wrap [return
+ [[archive state] (stm.read current)]
+ (if (archive.archived? archive module)
+ (wrap [(promise@wrap (#try.Success [archive state]))
#.None])
-
- #.None
- (case (if (archive.reserved? archive module)
- (do try.monad
- [module-id (archive.id module archive)]
- (wrap [module-id archive]))
- (archive.reserve module archive))
- (#try.Success [module-id archive])
- (do @
- [_ (stm.write [archive state] current)
- #let [[return signal] (:share [<type-vars>]
- {<Context>
- initial}
- {<Pending>
- (promise.promise [])})]
- _ (stm.update (dictionary.put module [return signal]) pending)]
+ (do @
+ [@pending (stm.read pending)]
+ (case (dictionary.get module @pending)
+ (#.Some [return signal])
(wrap [return
- (#.Some [[archive state]
- module-id
- signal])]))
-
- (#try.Failure error)
- (wrap [(promise@wrap (#try.Failure error))
- #.None]))))))))})
+ #.None])
+
+ #.None
+ (case (if (archive.reserved? archive module)
+ (do try.monad
+ [module-id (archive.id module archive)]
+ (wrap [module-id archive]))
+ (archive.reserve module archive))
+ (#try.Success [module-id archive])
+ (do @
+ [_ (stm.write [archive state] current)
+ #let [[return signal] (:share [<type-vars>]
+ {<Context>
+ initial}
+ {<Pending>
+ (promise.promise [])})]
+ _ (stm.update (dictionary.put module [return signal]) pending)]
+ (wrap [return
+ (#.Some [[archive state]
+ module-id
+ signal])]))
+
+ (#try.Failure error)
+ (wrap [(promise@wrap (#try.Failure error))
+ #.None]))))))))))})
_ (case signal
#.None
(wrap [])
@@ -363,16 +461,6 @@
try.assume
product.left))
- (exception: #export (module-cannot-import-itself {module Module})
- (exception.report
- ["Module" (%.text module)]))
-
- (def: (verify-no-self-import! module dependencies)
- (-> Module (List Module) (Try Any))
- (if (list.any? (text@= module) dependencies)
- (exception.throw ..module-cannot-import-itself [module])
- (#try.Success [])))
-
(def: #export (compile import static expander platform compilation context)
(All [<type-vars>]
(-> Import Static Expander <Platform> Compilation <Context> <Return>))
@@ -413,9 +501,8 @@
(#.Cons _)
(do @
- [_ (:: promise.monad wrap (verify-no-self-import! module new-dependencies))
- archive,document+ (|> new-dependencies
- (list@map import!)
+ [archive,document+ (|> new-dependencies
+ (list@map (import! module))
(monad.seq ..monad))
#let [archive (|> archive,document+
(list@map product.left)
@@ -452,5 +539,5 @@
(do @
[_ (ioW.freeze (get@ #&file-system platform) static archive)]
(promise@wrap (#try.Failure error))))))))))]
- (compiler compilation-module)))
+ (compiler archive.runtime-module compilation-module)))
))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/directive.lux b/stdlib/source/lux/tool/compiler/language/lux/directive.lux
index 8a5e0172a..11dc98bef 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/directive.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/directive.lux
@@ -73,7 +73,7 @@
)
(def: #export (set-current-module module)
- (All [anchor expression directive output]
+ (All [anchor expression directive]
(-> Module (Operation anchor expression directive Any)))
(do phase.monad
[_ (..lift-analysis
diff --git a/stdlib/source/program/aedifex/artifact.lux b/stdlib/source/program/aedifex/artifact.lux
index a6865f688..47a9027d0 100644
--- a/stdlib/source/program/aedifex/artifact.lux
+++ b/stdlib/source/program/aedifex/artifact.lux
@@ -1,6 +1,7 @@
(.module:
[lux (#- Name)
[abstract
+ ["." equivalence (#+ Equivalence)]
["." hash (#+ Hash)]]
[data
["." text
@@ -25,6 +26,14 @@
#name Name
#version Version})
+(def: #export equivalence
+ (Equivalence Artifact)
+ ($_ equivalence.product
+ text.equivalence
+ text.equivalence
+ text.equivalence
+ ))
+
(def: #export hash
(Hash Artifact)
($_ hash.product
diff --git a/stdlib/source/program/aedifex/dependency.lux b/stdlib/source/program/aedifex/dependency.lux
index 92ac3e8ac..18b6719ed 100644
--- a/stdlib/source/program/aedifex/dependency.lux
+++ b/stdlib/source/program/aedifex/dependency.lux
@@ -3,6 +3,7 @@
["." host (#+ import:)]
[abstract
[monad (#+ do)]
+ ["." equivalence (#+ Equivalence)]
["." hash (#+ Hash)]]
[control
["." io (#+ IO)]
@@ -43,6 +44,13 @@
{#artifact Artifact
#type ..Type})
+(def: #export equivalence
+ (Equivalence Dependency)
+ ($_ equivalence.product
+ //artifact.equivalence
+ text.equivalence
+ ))
+
(def: #export hash
(Hash Dependency)
($_ hash.product
diff --git a/stdlib/source/program/aedifex/format.lux b/stdlib/source/program/aedifex/format.lux
new file mode 100644
index 000000000..1107f4d13
--- /dev/null
+++ b/stdlib/source/program/aedifex/format.lux
@@ -0,0 +1,153 @@
+(.module:
+ [lux #*
+ [data
+ ["." text ("#@." equivalence)]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." list ("#@." functor)]
+ ["." set (#+ Set)]]]
+ [macro
+ ["." code]]]
+ ["." // #_
+ ["/" profile]
+ ["#." project (#+ Project)]
+ ["#." artifact (#+ Artifact)]
+ ["#." dependency (#+ Dependency)]])
+
+(type: #export (Format a)
+ (-> a Code))
+
+(def: (license [name url type])
+ (Format /.License)
+ (`' {#name (~ (code.text name))
+ #url (~ (code.text url))
+ #type (~ (case type
+ #/.Repo
+ (' #repo)
+
+ #/.Manual
+ (' #manual)))}))
+
+(def: (organization [name url])
+ (Format /.Organization)
+ (`' {#name (~ (code.text name))
+ #url (~ (code.text url))}))
+
+(def: (developer [name url organization])
+ (Format /.Developer)
+ (case organization
+ #.None
+ (`' {#name (~ (code.text name))
+ #url (~ (code.text url))})
+
+ (#.Some value)
+ (`' {#name (~ (code.text name))
+ #url (~ (code.text url))
+ #organization (~ (..organization value))})))
+
+(def: contributor
+ (Format /.Contributor)
+ ..developer)
+
+(type: Aggregate
+ (Dictionary Text Code))
+
+(def: aggregate
+ (Format Aggregate)
+ (|>> dictionary.entries
+ (list@map (function (_ [key value])
+ [(code.local-tag key) value]))
+ code.record))
+
+(def: empty
+ Aggregate
+ (dictionary.new text.hash))
+
+(def: (on-maybe field value format aggregate)
+ (All [a]
+ (-> Text (Maybe a) (Format a) Aggregate Aggregate))
+ (case value
+ #.None
+ aggregate
+
+ (#.Some value)
+ (dictionary.put field (format value) aggregate)))
+
+(def: (on-list field value format aggregate)
+ (All [a]
+ (-> Text (List a) (Format a) Aggregate Aggregate))
+ (case value
+ #.Nil
+ aggregate
+
+ value
+ (dictionary.put field (` [(~+ (list@map format value))]) aggregate)))
+
+(def: (on-set field value format aggregate)
+ (All [a]
+ (-> Text (Set a) (Format a) Aggregate Aggregate))
+ (..on-list field (set.to-list value) format aggregate))
+
+(def: (on-dictionary field value key-format value-format aggregate)
+ (All [k v]
+ (-> Text (Dictionary k v) (Format k) (Format v) Aggregate Aggregate))
+ (if (dictionary.empty? value)
+ aggregate
+ (dictionary.put field
+ (|> value
+ dictionary.entries
+ (list@map (function (_ [key value])
+ [(key-format key) (value-format value)]))
+ code.record)
+ aggregate)))
+
+(def: (info value)
+ (Format /.Info)
+ (|> ..empty
+ (..on-maybe "url" (get@ #/.url value) code.text)
+ (..on-maybe "scm" (get@ #/.scm value) code.text)
+ (..on-maybe "description" (get@ #/.description value) code.text)
+ (..on-list "licenses" (get@ #/.licenses value) ..license)
+ (..on-maybe "organization" (get@ #/.organization value) ..organization)
+ (..on-list "developers" (get@ #/.developers value) ..developer)
+ (..on-list "contributors" (get@ #/.contributors value) ..contributor)
+ ..aggregate))
+
+(def: (artifact' [group name version])
+ (-> Artifact (List Code))
+ (list (code.text group)
+ (code.text name)
+ (code.text version)))
+
+(def: (artifact value)
+ (Format Artifact)
+ (` [(~+ (..artifact' value))]))
+
+(def: (dependency [artifact type])
+ (Format Dependency)
+ (if (text@= //dependency.lux-library type)
+ (` [(~+ (..artifact' artifact))])
+ (` [(~+ (..artifact' artifact))
+ (~ (code.text type))])))
+
+(def: #export (profile value)
+ (Format /.Profile)
+ (|> ..empty
+ (..on-list "parents" (get@ #/.parents value) code.text)
+ (..on-maybe "identity" (get@ #/.identity value) ..artifact)
+ (..on-maybe "info" (get@ #/.info value) ..info)
+ (..on-set "repositories" (get@ #/.repositories value) code.text)
+ (..on-set "dependencies" (get@ #/.dependencies value) ..dependency)
+ (..on-set "sources" (get@ #/.sources value) code.text)
+ (..on-maybe "target" (get@ #/.target value) code.text)
+ (..on-maybe "program" (get@ #/.program value) code.text)
+ (..on-maybe "test" (get@ #/.test value) code.text)
+ (..on-dictionary "deploy-repositories" (get@ #/.deploy-repositories value) code.text code.text)
+ ..aggregate))
+
+(def: #export project
+ (Format Project)
+ (|>> dictionary.entries
+ (list@map (function (_ [key value])
+ [(code.text key) (..profile value)]))
+ code.record))
diff --git a/stdlib/source/program/aedifex/parser.lux b/stdlib/source/program/aedifex/parser.lux
index 87f41f2c6..1799db09e 100644
--- a/stdlib/source/program/aedifex/parser.lux
+++ b/stdlib/source/program/aedifex/parser.lux
@@ -81,13 +81,13 @@
(dictionary.from-list text.hash)
(<c>.record (<>.some (<>.and <c>.local-tag
<c>.any))))]
- (<c>.tuple ($_ <>.and
- (..singular input "name" ..name)
- (..singular input "url" ..url)
- (<>.default #/.Repo
- (..singular input "type"
- (<>.or (<c>.this! (' #repo))
- (<c>.this! (' #manual)))))))))
+ ($_ <>.and
+ (..singular input "name" ..name)
+ (..singular input "url" ..url)
+ (<>.default #/.Repo
+ (..singular input "type"
+ (<>.or (<c>.this! (' #repo))
+ (<c>.this! (' #manual))))))))
(def: organization
(Parser /.Organization)
@@ -163,9 +163,10 @@
<c>.text)
(def: deploy-repository
- (Parser [Text //dependency.Repository])
- (<c>.tuple (<>.and <c>.text
- ..repository)))
+ (Parser (List [Text //dependency.Repository]))
+ (<c>.record (<>.some
+ (<>.and <c>.text
+ ..repository))))
(def: profile
(Parser /.Profile)
@@ -207,7 +208,7 @@
^deploy-repositories (: (Parser (Dictionary Text //dependency.Repository))
(<| (:: @ map (dictionary.from-list text.hash))
(<>.default (list))
- (..plural input "deploy-repositories" ..deploy-repository)))]]
+ (..singular input "deploy-repositories" ..deploy-repository)))]]
($_ <>.and
^parents
^identity
diff --git a/stdlib/source/program/aedifex/profile.lux b/stdlib/source/program/aedifex/profile.lux
index 5e5cb6175..02ae69ac8 100644
--- a/stdlib/source/program/aedifex/profile.lux
+++ b/stdlib/source/program/aedifex/profile.lux
@@ -1,7 +1,8 @@
(.module:
[lux (#- Info Source Module Name)
[abstract
- [monoid (#+ Monoid)]]
+ [monoid (#+ Monoid)]
+ ["." equivalence (#+ Equivalence)]]
[control
["." exception (#+ exception:)]]
[data
@@ -20,7 +21,7 @@
[archive
[descriptor (#+ Module)]]]]]]
[//
- [artifact (#+ Artifact)]
+ ["." artifact (#+ Artifact)]
["." dependency]])
(def: #export file
@@ -30,11 +31,32 @@
#Repo
#Manual)
+(structure: distribution-equivalence
+ (Equivalence Distribution)
+
+ (def: (= reference subject)
+ (case [reference subject]
+ (^template [<tag>]
+ [<tag> <tag>]
+ true)
+ ([#Repo]
+ [#Manual])
+
+ _
+ false)))
+
(type: #export License
[Text
URL
Distribution])
+(def: license-equivalence
+ (Equivalence License)
+ ($_ equivalence.product
+ text.equivalence
+ text.equivalence
+ ..distribution-equivalence))
+
(type: #export SCM
URL)
@@ -42,6 +64,12 @@
[Text
URL])
+(def: organization-equivalence
+ (Equivalence Organization)
+ ($_ equivalence.product
+ text.equivalence
+ text.equivalence))
+
(type: #export Email
Text)
@@ -50,6 +78,13 @@
Email
(Maybe Organization)])
+(def: developer-equivalence
+ (Equivalence Developer)
+ ($_ equivalence.product
+ text.equivalence
+ text.equivalence
+ (maybe.equivalence ..organization-equivalence)))
+
(type: #export Contributor
Developer)
@@ -62,6 +97,17 @@
#developers (List Developer)
#contributors (List Contributor)})
+(def: info-equivalence
+ (Equivalence Info)
+ ($_ equivalence.product
+ (maybe.equivalence text.equivalence)
+ (maybe.equivalence text.equivalence)
+ (maybe.equivalence text.equivalence)
+ (list.equivalence ..license-equivalence)
+ (maybe.equivalence ..organization-equivalence)
+ (list.equivalence ..developer-equivalence)
+ (list.equivalence ..developer-equivalence)))
+
(def: #export default-info
Info
{#url #.None
@@ -105,7 +151,42 @@
#test (Maybe Module)
#deploy-repositories (Dictionary Text dependency.Repository)})
-(exception: #export no-identity)
+(def: #export empty
+ Profile
+ {#parents (list)
+ #identity #.None
+ #info #.None
+ #repositories (set.new text.hash)
+ #dependencies (set.new dependency.hash)
+ #sources (set.new text.hash)
+ #target #.None
+ #program #.None
+ #test #.None
+ #deploy-repositories (dictionary.new text.hash)})
+
+(def: #export equivalence
+ (Equivalence Profile)
+ ($_ equivalence.product
+ ## #parents
+ (list.equivalence text.equivalence)
+ ## #identity
+ (maybe.equivalence artifact.equivalence)
+ ## #info
+ (maybe.equivalence ..info-equivalence)
+ ## #repositories
+ set.equivalence
+ ## #dependencies
+ set.equivalence
+ ## #sources
+ set.equivalence
+ ## #target
+ (maybe.equivalence text.equivalence)
+ ## #program
+ (maybe.equivalence text.equivalence)
+ ## #test
+ (maybe.equivalence text.equivalence)
+ ## #deploy-repositories
+ (dictionary.equivalence text.equivalence)))
(structure: #export monoid
(Monoid Profile)
@@ -133,3 +214,5 @@
#program (maybe@compose (get@ #program override) (get@ #program baseline))
#test (maybe@compose (get@ #test override) (get@ #test baseline))
#deploy-repositories (dictionary.merge (get@ #deploy-repositories override) (get@ #deploy-repositories baseline))}))
+
+(exception: #export no-identity)
diff --git a/stdlib/source/program/aedifex/project.lux b/stdlib/source/program/aedifex/project.lux
index 81a8de1af..2e205f722 100644
--- a/stdlib/source/program/aedifex/project.lux
+++ b/stdlib/source/program/aedifex/project.lux
@@ -1,7 +1,8 @@
(.module:
[lux (#- Name)
[abstract
- ["." monad (#+ do)]]
+ ["." monad (#+ do)]
+ ["." equivalence (#+ Equivalence)]]
[control
["." try (#+ Try)]
["." exception (#+ exception:)]]
@@ -18,6 +19,13 @@
(type: #export Project
(Dictionary Name Profile))
+(def: #export empty
+ (dictionary.from-list text.hash (list [//.default //.empty])))
+
+(def: #export equivalence
+ (Equivalence Project)
+ (dictionary.equivalence //.equivalence))
+
(exception: #export (unknown-profile {name Name})
(exception.report
["Name" (%.text name)]))
diff --git a/stdlib/source/spec/lux/abstract/comonad.lux b/stdlib/source/spec/lux/abstract/comonad.lux
new file mode 100644
index 000000000..3dfda0bbf
--- /dev/null
+++ b/stdlib/source/spec/lux/abstract/comonad.lux
@@ -0,0 +1,61 @@
+(.module:
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [data
+ [number
+ ["n" nat]]]
+ [math
+ ["." random]]
+ ["_" test (#+ Test)]]
+ {1
+ ["." / (#+ CoMonad)]}
+ [//
+ [functor (#+ Injection Comparison)]])
+
+(def: (left-identity injection (^open "_@."))
+ (All [f] (-> (Injection f) (CoMonad f) Test))
+ (do {@ random.monad}
+ [sample random.nat
+ morphism (:: @ map (function (_ diff)
+ (|>> _@unwrap (n.+ diff)))
+ random.nat)
+ #let [start (injection sample)]]
+ (_.test "Left identity."
+ (n.= (morphism start)
+ (|> start _@split (_@map morphism) _@unwrap)))))
+
+(def: (right-identity injection comparison (^open "_@."))
+ (All [f] (-> (Injection f) (Comparison f) (CoMonad f) Test))
+ (do random.monad
+ [sample random.nat
+ #let [start (injection sample)
+ == (comparison n.=)]]
+ (_.test "Right identity."
+ (== start
+ (|> start _@split (_@map _@unwrap))))))
+
+(def: (associativity injection comparison (^open "_@."))
+ (All [f] (-> (Injection f) (Comparison f) (CoMonad f) Test))
+ (do {@ random.monad}
+ [sample random.nat
+ increase (:: @ map (function (_ diff)
+ (|>> _@unwrap (n.+ diff)))
+ random.nat)
+ decrease (:: @ map (function (_ diff)
+ (|>> _@unwrap(n.- diff)))
+ random.nat)
+ #let [start (injection sample)
+ == (comparison n.=)]]
+ (_.test "Associativity."
+ (== (|> start _@split (_@map (|>> _@split (_@map increase) decrease)))
+ (|> start _@split (_@map increase) _@split (_@map decrease))))))
+
+(def: #export (spec injection comparison monad)
+ (All [f] (-> (Injection f) (Comparison f) (CoMonad f) Test))
+ (<| (_.with-cover [/.CoMonad])
+ ($_ _.and
+ (..left-identity injection monad)
+ (..right-identity injection comparison monad)
+ (..associativity injection comparison monad)
+ )))
diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux
new file mode 100644
index 000000000..7286aa50a
--- /dev/null
+++ b/stdlib/source/test/aedifex.lux
@@ -0,0 +1,21 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [control
+ [io (#+ io)]
+ [parser
+ [cli (#+ program:)]]]]
+ ["." / #_
+ ["#." parser]])
+
+(def: test
+ Test
+ ($_ _.and
+ /parser.test
+ ))
+
+(program: args
+ (<| io
+ _.run!
+ (_.times 100)
+ ..test))
diff --git a/stdlib/source/test/aedifex/parser.lux b/stdlib/source/test/aedifex/parser.lux
new file mode 100644
index 000000000..497533fbf
--- /dev/null
+++ b/stdlib/source/test/aedifex/parser.lux
@@ -0,0 +1,212 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ [hash (#+ Hash)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ [parser
+ ["<c>" code]]]
+ [data
+ ["." text
+ ["%" format (#+ format)]]
+ [number
+ ["n" nat]]
+ [collection
+ ["." set (#+ Set)]
+ ["." dictionary (#+ Dictionary)]
+ ["." list ("#@." functor)]]]
+ [math
+ ["." random (#+ Random) ("#@." monad)]]
+ [macro
+ ["." code]]]
+ {#program
+ ["." /
+ ["/#" // #_
+ ["#" profile]
+ ["#." project (#+ Project)]
+ ["#." artifact (#+ Artifact)]
+ ["#." dependency (#+ Repository Dependency)]
+ ["#." format]]]})
+
+(def: distribution
+ (Random //.Distribution)
+ (random.or (random@wrap [])
+ (random@wrap [])))
+
+(def: license
+ (Random //.License)
+ ($_ random.and
+ (random.ascii/alpha 1)
+ (random.ascii/alpha 1)
+ ..distribution))
+
+(def: scm
+ (Random //.SCM)
+ (random.ascii/alpha 1))
+
+(def: organization
+ (Random //.Organization)
+ ($_ random.and
+ (random.ascii/alpha 1)
+ (random.ascii/alpha 1)))
+
+(def: email
+ (Random //.Email)
+ (random.ascii/alpha 1))
+
+(def: developer
+ (Random //.Developer)
+ ($_ random.and
+ (random.ascii/alpha 1)
+ (random.ascii/alpha 1)
+ (random.maybe organization)))
+
+(def: contributor
+ (Random //.Contributor)
+ ..developer)
+
+(def: (list-of random)
+ (All [a] (-> (Random a) (Random (List a))))
+ (do {@ random.monad}
+ [size (:: @ map (n.% 5) random.nat)]
+ (random.list size random)))
+
+(def: (set-of hash random)
+ (All [a] (-> (Hash a) (Random a) (Random (Set a))))
+ (:: random.functor map
+ (set.from-list hash)
+ (..list-of random)))
+
+(def: (dictionary-of key-hash key-random value-random)
+ (All [k v] (-> (Hash k) (Random k) (Random v) (Random (Dictionary k v))))
+ (:: random.functor map
+ (dictionary.from-list key-hash)
+ (..list-of (random.and key-random value-random))))
+
+(def: info
+ (Random //.Info)
+ ($_ random.and
+ (random.maybe (random.ascii/alpha 1))
+ (random.maybe ..scm)
+ (random.maybe (random.ascii/alpha 1))
+ (..list-of ..license)
+ (random.maybe ..organization)
+ (..list-of ..developer)
+ (..list-of ..contributor)
+ ))
+
+(def: name
+ (Random //.Name)
+ (random.ascii/alpha 1))
+
+(def: artifact
+ (Random Artifact)
+ ($_ random.and
+ (random.ascii/alpha 1)
+ (random.ascii/alpha 1)
+ (random.ascii/alpha 1)))
+
+(def: repository
+ (Random Repository)
+ (random.ascii/alpha 1))
+
+(def: dependency
+ (Random Dependency)
+ ($_ random.and
+ ..artifact
+ (random.ascii/alpha 1)))
+
+(def: source
+ (Random //.Source)
+ (random.ascii/alpha 1))
+
+(def: target
+ (Random //.Target)
+ (random.ascii/alpha 1))
+
+(def: profile
+ (Random //.Profile)
+ ($_ random.and
+ (..list-of ..name)
+ (random.maybe ..artifact)
+ (random.maybe ..info)
+ (..set-of text.hash ..repository)
+ (..set-of //dependency.hash ..dependency)
+ (..set-of text.hash ..source)
+ (random.maybe ..target)
+ (random.maybe (random.ascii/alpha 1))
+ (random.maybe (random.ascii/alpha 1))
+ (..dictionary-of text.hash (random.ascii/alpha 1) ..repository)
+ ))
+
+(def: project
+ (Random Project)
+ (..dictionary-of text.hash ..name ..profile))
+
+(def: with-default-sources
+ (-> //.Profile //.Profile)
+ (update@ #//.sources
+ (: (-> (Set //.Source) (Set //.Source))
+ (function (_ sources)
+ (if (set.empty? sources)
+ (set.from-list text.hash (list //.default-source))
+ sources)))))
+
+(def: single-profile
+ Test
+ (do random.monad
+ [expected ..profile]
+ (_.test "Single profile."
+ (|> expected
+ //format.profile
+ list
+ (<c>.run /.project)
+ (case> (#try.Success actual)
+ (|> expected
+ ..with-default-sources
+ [//.default]
+ list
+ (dictionary.from-list text.hash)
+ (:: //project.equivalence = actual))
+
+ (#try.Failure error)
+ false)))))
+
+(def: (with-empty-profile project)
+ (-> Project Project)
+ (if (dictionary.empty? project)
+ //project.empty
+ project))
+
+(def: multiple-profiles
+ Test
+ (do random.monad
+ [expected ..project]
+ (_.test "Multiple profiles."
+ (|> expected
+ //format.project
+ list
+ (<c>.run /.project)
+ (case> (#try.Success actual)
+ (|> expected
+ ..with-empty-profile
+ dictionary.entries
+ (list@map (function (_ [name profile])
+ [name (..with-default-sources profile)]))
+ (dictionary.from-list text.hash)
+ (:: //project.equivalence = actual))
+
+ (#try.Failure error)
+ false)))))
+
+(def: #export test
+ Test
+ (<| (_.covering /._)
+ (_.with-cover [/.project]
+ ($_ _.and
+ ..single-profile
+ ..multiple-profiles
+ ))))
diff --git a/stdlib/source/test/lux/data/identity.lux b/stdlib/source/test/lux/data/identity.lux
index 65d7d1a48..cc2ccf096 100644
--- a/stdlib/source/test/lux/data/identity.lux
+++ b/stdlib/source/test/lux/data/identity.lux
@@ -10,7 +10,8 @@
[/
["$." functor (#+ Injection Comparison)]
["$." apply]
- ["$." monad]]}]
+ ["$." monad]
+ ["$." comonad]]}]
[data
["." text ("#@." monoid equivalence)
["%" format (#+ format)]]]]
@@ -28,18 +29,15 @@
(def: #export test
Test
- (<| (_.context (%.name (name-of /.Identity)))
+ (<| (_.covering /._)
+ (_.with-cover [/.Identity])
($_ _.and
- ($functor.spec ..injection ..comparison /.functor)
- ($apply.spec ..injection ..comparison /.apply)
- ($monad.spec ..injection ..comparison /.monad)
-
- (let [(^open "/@.") /.comonad]
- (_.test "CoMonad does not affect values."
- (and (text@= "yololol" (/@unwrap "yololol"))
- (text@= "yololol" (be /.comonad
- [f text@compose
- a "yolo"
- b "lol"]
- (f a b))))))
+ (_.with-cover [/.functor]
+ ($functor.spec ..injection ..comparison /.functor))
+ (_.with-cover [/.apply]
+ ($apply.spec ..injection ..comparison /.apply))
+ (_.with-cover [/.monad]
+ ($monad.spec ..injection ..comparison /.monad))
+ (_.with-cover [/.comonad]
+ ($comonad.spec ..injection ..comparison /.comonad))
)))
diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux
index 4a5672382..f2468ab4f 100644
--- a/stdlib/source/test/lux/target/jvm.lux
+++ b/stdlib/source/test/lux/target/jvm.lux
@@ -226,8 +226,8 @@
(def: $Float::random
(Random java/lang/Float)
(:: random.monad map
- (|>> (i.% +1024) i.frac (:coerce java/lang/Double) host.double-to-float)
- random.int))
+ (|>> (:coerce java/lang/Double) host.double-to-float)
+ random.frac))
(def: $Float::literal /.float)
(def: $Float::primitive
(Primitive java/lang/Float)
@@ -288,27 +288,23 @@
#random ..$String::random
#literal ..$String::literal})
-(with-expansions [<comparison> (for {@.old
- "jvm leq"
- @.jvm
- "jvm long ="})]
- (template [<name> <bits> <type> <push> <wrap> <message> <to-long> <unsigned>]
- [(def: <name>
- Test
- (do {@ random.monad}
- [expected (:: @ map (i64.and (i64.mask <bits>)) random.nat)]
- (<| (_.lift <message>)
- (..bytecode (for {@.old
- (|>> (:coerce <type>) <to-long> (<comparison> expected))
- @.jvm
- (|>> (:coerce <type>) <to-long> "jvm object cast" (<comparison> ("jvm object cast" (:coerce java/lang/Long expected))))}))
- (do /.monad
- [_ (<push> (|> expected <unsigned> try.assume))]
- <wrap>))))]
+(template [<name> <bits> <type> <push> <wrap> <message> <to-long> <unsigned>]
+ [(def: <name>
+ Test
+ (do {@ random.monad}
+ [expected (:: @ map (i64.and (i64.mask <bits>)) random.nat)]
+ (<| (_.lift <message>)
+ (..bytecode (for {@.old
+ (|>> (:coerce <type>) <to-long> ("jvm leq" expected))
+ @.jvm
+ (|>> (:coerce <type>) <to-long> "jvm object cast" ("jvm long =" ("jvm object cast" (:coerce java/lang/Long expected))))}))
+ (do /.monad
+ [_ (<push> (|> expected <unsigned> try.assume))]
+ <wrap>))))]
- [byte 7 java/lang/Byte /.bipush ..$Byte::wrap "BIPUSH" host.byte-to-long /unsigned.u1]
- [short 15 java/lang/Short /.sipush ..$Short::wrap "SIPUSH" host.short-to-long /unsigned.u2]
- ))
+ [byte 7 java/lang/Byte /.bipush ..$Byte::wrap "BIPUSH" host.byte-to-long /unsigned.u1]
+ [short 15 java/lang/Short /.sipush ..$Short::wrap "SIPUSH" host.short-to-long /unsigned.u2]
+ )
(template [<name> <type>]
[(template: (<name> <old-extension> <new-extension>)
@@ -341,19 +337,16 @@
(def: int
Test
- (let [int (with-expansions [<comparison> (for {@.old "jvm ieq"
- @.jvm "jvm int ="})]
- (: (-> java/lang/Integer (Bytecode Any) (Random Bit))
- (function (_ expected bytecode)
- (<| (..bytecode (for {@.old
- (|>> (:coerce java/lang/Integer) (<comparison> expected))
-
- @.jvm
- (|>> (:coerce java/lang/Integer) "jvm object cast"
- (<comparison> ("jvm object cast" expected)))}))
- (do /.monad
- [_ bytecode]
- ..$Integer::wrap)))))
+ (let [int (: (-> java/lang/Integer (Bytecode Any) (Random Bit))
+ (function (_ expected bytecode)
+ (<| (..bytecode (for {@.old
+ (|>> (:coerce java/lang/Integer) ("jvm ieq" expected))
+
+ @.jvm
+ (|>> (:coerce java/lang/Integer) "jvm object cast" ("jvm int =" ("jvm object cast" expected)))}))
+ (do /.monad
+ [_ bytecode]
+ ..$Integer::wrap))))
unary (: (-> (-> java/lang/Integer java/lang/Integer) (Bytecode Any) (Random Bit))
(function (_ reference instruction)
(do random.monad
@@ -425,290 +418,296 @@
(def: long
Test
- (with-expansions [<comparison> (for {@.old "jvm leq"
- @.jvm "jvm long ="})]
- (let [long (: (-> java/lang/Long (Bytecode Any) (Random Bit))
+ (let [long (: (-> java/lang/Long (Bytecode Any) (Random Bit))
+ (function (_ expected bytecode)
+ (<| (..bytecode (for {@.old
+ (|>> (:coerce Int) (i.= expected))
+
+ @.jvm
+ (|>> (:coerce java/lang/Long) "jvm object cast" ("jvm long =" ("jvm object cast" expected)))}))
+ (do /.monad
+ [_ bytecode]
+ ..$Long::wrap))))
+ unary (: (-> (-> java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit))
+ (function (_ reference instruction)
+ (do random.monad
+ [subject ..$Long::random]
+ (long (reference subject)
+ (do /.monad
+ [_ (..$Long::literal subject)]
+ instruction)))))
+ binary (: (-> (-> java/lang/Long java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit))
+ (function (_ reference instruction)
+ (do random.monad
+ [parameter ..$Long::random
+ subject ..$Long::random]
+ (long (reference parameter subject)
+ (do /.monad
+ [_ (..$Long::literal subject)
+ _ (..$Long::literal parameter)]
+ instruction)))))
+ shift (: (-> (-> java/lang/Integer java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit))
+ (function (_ reference instruction)
+ (do {@ random.monad}
+ [parameter (:: @ map (|>> (n.% 64) (:coerce java/lang/Long)) random.nat)
+ subject ..$Long::random]
+ (long (reference (host.long-to-int parameter) subject)
+ (do /.monad
+ [_ (..$Long::literal subject)
+ _ (..$Integer::literal (host.long-to-int parameter))]
+ instruction)))))
+ literal ($_ _.and
+ (_.lift "LCONST_0" (long (:coerce java/lang/Long +0) /.lconst-0))
+ (_.lift "LCONST_1" (long (:coerce java/lang/Long +1) /.lconst-1))
+ (_.lift "LDC2_W/LONG"
+ (do random.monad
+ [expected ..$Long::random]
+ (long expected (..$Long::literal expected)))))
+ arithmetic ($_ _.and
+ (_.lift "LADD" (binary (long/2 "jvm ladd" "jvm long +") /.ladd))
+ (_.lift "LSUB" (binary (long/2 "jvm lsub" "jvm long -") /.lsub))
+ (_.lift "LMUL" (binary (long/2 "jvm lmul" "jvm long *") /.lmul))
+ (_.lift "LDIV" (binary (long/2 "jvm ldiv" "jvm long /") /.ldiv))
+ (_.lift "LREM" (binary (long/2 "jvm lrem" "jvm long %") /.lrem))
+ (_.lift "LNEG" (unary (function (_ value)
+ ((long/2 "jvm lsub" "jvm long -")
+ value
+ (:coerce java/lang/Long +0)))
+ /.lneg)))
+ bitwise ($_ _.and
+ (_.lift "LAND" (binary (long/2 "jvm land" "jvm long and") /.land))
+ (_.lift "LOR" (binary (long/2 "jvm lor" "jvm long or") /.lor))
+ (_.lift "LXOR" (binary (long/2 "jvm lxor" "jvm long xor") /.lxor))
+ (_.lift "LSHL" (shift (int+long/2 "jvm lshl" "jvm long shl") /.lshl))
+ (_.lift "LSHR" (shift (int+long/2 "jvm lshr" "jvm long shr") /.lshr))
+ (_.lift "LUSHR" (shift (int+long/2 "jvm lushr" "jvm long ushr") /.lushr)))
+ comparison (_.lift "LCMP"
+ (do random.monad
+ [reference ..$Long::random
+ subject ..$Long::random
+ #let [expected (cond (i.= (:coerce Int reference) (:coerce Int subject))
+ (:coerce java/lang/Long +0)
+
+ (i.> (:coerce Int reference) (:coerce Int subject))
+ (:coerce java/lang/Long +1)
+
+ ## (i.< (:coerce Int reference) (:coerce Int subject))
+ (:coerce java/lang/Long -1))]]
+ (<| (..bytecode (for {@.old
+ (|>> (:coerce Int) (i.= expected))
+
+ @.jvm
+ (|>> (:coerce java/lang/Long) "jvm object cast" ("jvm long =" ("jvm object cast" expected)))}))
+ (do /.monad
+ [_ (..$Long::literal subject)
+ _ (..$Long::literal reference)
+ _ /.lcmp
+ _ /.i2l]
+ ..$Long::wrap))))]
+ ($_ _.and
+ (<| (_.context "literal")
+ literal)
+ (<| (_.context "arithmetic")
+ arithmetic)
+ (<| (_.context "bitwise")
+ bitwise)
+ (<| (_.context "comparison")
+ comparison)
+ )))
+
+(def: float
+ Test
+ (let [float (: (-> java/lang/Float (Bytecode Any) (Random Bit))
+ (function (_ expected bytecode)
+ (<| (..bytecode (for {@.old
+ (function (_ actual)
+ (or (|> actual (:coerce java/lang/Float) ("jvm feq" expected))
+ (and (f.not-a-number? (:coerce Frac (host.float-to-double expected)))
+ (f.not-a-number? (:coerce Frac (host.float-to-double (:coerce java/lang/Float actual)))))))
+
+ @.jvm
+ (function (_ actual)
+ (or (|> actual (:coerce java/lang/Float) "jvm object cast" ("jvm float =" ("jvm object cast" expected)))
+ (and (f.not-a-number? (:coerce Frac (host.float-to-double expected)))
+ (f.not-a-number? (:coerce Frac (host.float-to-double (:coerce java/lang/Float actual)))))))}))
+ (do /.monad
+ [_ bytecode]
+ ..$Float::wrap))))
+ unary (: (-> (-> java/lang/Float java/lang/Float)
+ (Bytecode Any)
+ (Random Bit))
+ (function (_ reference instruction)
+ (do random.monad
+ [subject ..$Float::random]
+ (float (reference subject)
+ (do /.monad
+ [_ (..$Float::literal subject)]
+ instruction)))))
+ binary (: (-> (-> java/lang/Float java/lang/Float java/lang/Float)
+ (Bytecode Any)
+ (Random Bit))
+ (function (_ reference instruction)
+ (do random.monad
+ [parameter ..$Float::random
+ subject ..$Float::random]
+ (float (reference parameter subject)
+ (do /.monad
+ [_ (..$Float::literal subject)
+ _ (..$Float::literal parameter)]
+ instruction)))))
+ literal ($_ _.and
+ (_.lift "FCONST_0" (float (host.double-to-float (:coerce java/lang/Double +0.0)) /.fconst-0))
+ (_.lift "FCONST_1" (float (host.double-to-float (:coerce java/lang/Double +1.0)) /.fconst-1))
+ (_.lift "FCONST_2" (float (host.double-to-float (:coerce java/lang/Double +2.0)) /.fconst-2))
+ (_.lift "LDC_W/FLOAT"
+ (do random.monad
+ [expected ..$Float::random]
+ (float expected (..$Float::literal expected)))))
+ arithmetic ($_ _.and
+ (_.lift "FADD" (binary (float/2 "jvm fadd" "jvm float +") /.fadd))
+ (_.lift "FSUB" (binary (float/2 "jvm fsub" "jvm float -") /.fsub))
+ (_.lift "FMUL" (binary (float/2 "jvm fmul" "jvm float *") /.fmul))
+ (_.lift "FDIV" (binary (float/2 "jvm fdiv" "jvm float /") /.fdiv))
+ (_.lift "FREM" (binary (float/2 "jvm frem" "jvm float %") /.frem))
+ (_.lift "FNEG" (unary (function (_ value)
+ ((float/2 "jvm fsub" "jvm float -")
+ value
+ (host.double-to-float (:coerce java/lang/Double +0.0))))
+ /.fneg)))
+ comparison (: (-> (Bytecode Any) (-> java/lang/Float java/lang/Float Bit) (Random Bit))
+ (function (_ instruction standard)
+ (do random.monad
+ [reference ..$Float::random
+ subject ..$Float::random
+ #let [expected (if (for {@.old
+ ("jvm feq" reference subject)
+
+ @.jvm
+ ("jvm float =" ("jvm object cast" reference) ("jvm object cast" subject))})
+ +0
+ (if (standard reference subject)
+ +1
+ -1))]]
+ (<| (..bytecode (|>> (:coerce Int) (i.= expected)))
+ (do /.monad
+ [_ (..$Float::literal subject)
+ _ (..$Float::literal reference)
+ _ instruction
+ _ /.i2l]
+ ..$Long::wrap)))))
+ comparison-standard (: (-> java/lang/Float java/lang/Float Bit)
+ (function (_ reference subject)
+ (for {@.old
+ ("jvm fgt" subject reference)
+
+ @.jvm
+ ("jvm float <" ("jvm object cast" subject) ("jvm object cast" reference))})))
+ comparison ($_ _.and
+ (_.lift "FCMPL" (comparison /.fcmpl comparison-standard))
+ (_.lift "FCMPG" (comparison /.fcmpg comparison-standard)))]
+ ($_ _.and
+ (<| (_.context "literal")
+ literal)
+ (<| (_.context "arithmetic")
+ arithmetic)
+ (<| (_.context "comparison")
+ comparison)
+ )))
+
+(def: double
+ Test
+ (let [double (: (-> java/lang/Double (Bytecode Any) (Random Bit))
(function (_ expected bytecode)
(<| (..bytecode (for {@.old
- (|>> (:coerce Int) (i.= expected))
+ (function (_ actual)
+ (or (|> actual (:coerce java/lang/Double) ("jvm deq" expected))
+ (and (f.not-a-number? (:coerce Frac expected))
+ (f.not-a-number? (:coerce Frac actual)))))
@.jvm
- (|>> (:coerce java/lang/Long) "jvm object cast" (<comparison> ("jvm object cast" expected)))}))
+ (function (_ actual)
+ (or (|> actual (:coerce java/lang/Double) "jvm object cast" ("jvm double =" ("jvm object cast" expected)))
+ (and (f.not-a-number? (:coerce Frac expected))
+ (f.not-a-number? (:coerce Frac actual)))))}))
(do /.monad
[_ bytecode]
- ..$Long::wrap))))
- unary (: (-> (-> java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit))
- (function (_ reference instruction)
- (do random.monad
- [subject ..$Long::random]
- (long (reference subject)
+ ..$Double::wrap))))
+ unary (: (-> (-> java/lang/Double java/lang/Double) (Bytecode Any) (Random Bit))
+ (function (_ reference instruction)
+ (do random.monad
+ [subject ..$Double::random]
+ (double (reference subject)
(do /.monad
- [_ (..$Long::literal subject)]
+ [_ (..$Double::literal subject)]
instruction)))))
- binary (: (-> (-> java/lang/Long java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit))
- (function (_ reference instruction)
- (do random.monad
- [parameter ..$Long::random
- subject ..$Long::random]
- (long (reference parameter subject)
+ binary (: (-> (-> java/lang/Double java/lang/Double java/lang/Double) (Bytecode Any) (Random Bit))
+ (function (_ reference instruction)
+ (do random.monad
+ [parameter ..$Double::random
+ subject ..$Double::random]
+ (double (reference parameter subject)
(do /.monad
- [_ (..$Long::literal subject)
- _ (..$Long::literal parameter)]
+ [_ (..$Double::literal subject)
+ _ (..$Double::literal parameter)]
instruction)))))
- shift (: (-> (-> java/lang/Integer java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit))
- (function (_ reference instruction)
- (do {@ random.monad}
- [parameter (:: @ map (|>> (n.% 64) (:coerce java/lang/Long)) random.nat)
- subject ..$Long::random]
- (long (reference (host.long-to-int parameter) subject)
- (do /.monad
- [_ (..$Long::literal subject)
- _ (..$Integer::literal (host.long-to-int parameter))]
- instruction)))))
- literal ($_ _.and
- (_.lift "LCONST_0" (long (:coerce java/lang/Long +0) /.lconst-0))
- (_.lift "LCONST_1" (long (:coerce java/lang/Long +1) /.lconst-1))
- (_.lift "LDC2_W/LONG"
- (do random.monad
- [expected ..$Long::random]
- (long expected (..$Long::literal expected)))))
- arithmetic ($_ _.and
- (_.lift "LADD" (binary (long/2 "jvm ladd" "jvm long +") /.ladd))
- (_.lift "LSUB" (binary (long/2 "jvm lsub" "jvm long -") /.lsub))
- (_.lift "LMUL" (binary (long/2 "jvm lmul" "jvm long *") /.lmul))
- (_.lift "LDIV" (binary (long/2 "jvm ldiv" "jvm long /") /.ldiv))
- (_.lift "LREM" (binary (long/2 "jvm lrem" "jvm long %") /.lrem))
- (_.lift "LNEG" (unary (function (_ value)
- ((long/2 "jvm lsub" "jvm long -")
- value
- (:coerce java/lang/Long +0)))
- /.lneg)))
- bitwise ($_ _.and
- (_.lift "LAND" (binary (long/2 "jvm land" "jvm long and") /.land))
- (_.lift "LOR" (binary (long/2 "jvm lor" "jvm long or") /.lor))
- (_.lift "LXOR" (binary (long/2 "jvm lxor" "jvm long xor") /.lxor))
- (_.lift "LSHL" (shift (int+long/2 "jvm lshl" "jvm long shl") /.lshl))
- (_.lift "LSHR" (shift (int+long/2 "jvm lshr" "jvm long shr") /.lshr))
- (_.lift "LUSHR" (shift (int+long/2 "jvm lushr" "jvm long ushr") /.lushr)))
- comparison (_.lift "LCMP"
- (do random.monad
- [reference ..$Long::random
- subject ..$Long::random
- #let [expected (cond (i.= (:coerce Int reference) (:coerce Int subject))
- (:coerce java/lang/Long +0)
-
- (i.> (:coerce Int reference) (:coerce Int subject))
- (:coerce java/lang/Long +1)
-
- ## (i.< (:coerce Int reference) (:coerce Int subject))
- (:coerce java/lang/Long -1))]]
- (<| (..bytecode (for {@.old
- (|>> (:coerce Int) (i.= expected))
-
- @.jvm
- (|>> (:coerce java/lang/Long) "jvm object cast" (<comparison> ("jvm object cast" expected)))}))
- (do /.monad
- [_ (..$Long::literal subject)
- _ (..$Long::literal reference)
- _ /.lcmp
- _ /.i2l]
- ..$Long::wrap))))]
- ($_ _.and
- (<| (_.context "literal")
- literal)
- (<| (_.context "arithmetic")
- arithmetic)
- (<| (_.context "bitwise")
- bitwise)
- (<| (_.context "comparison")
- comparison)
- ))))
-
-(def: float
- Test
- (with-expansions [<comparison> (for {@.old "jvm feq"
- @.jvm "jvm float ="})]
- (let [float (: (-> java/lang/Float (Bytecode Any) (Random Bit))
- (function (_ expected bytecode)
- (<| (..bytecode (for {@.old
- (|>> (:coerce java/lang/Float) ("jvm feq" expected))
-
- @.jvm
- (|>> (:coerce java/lang/Float) "jvm object cast" (<comparison> ("jvm object cast" expected)))}))
- (do /.monad
- [_ bytecode]
- ..$Float::wrap))))
- unary (: (-> (-> java/lang/Float java/lang/Float)
- (Bytecode Any)
- (Random Bit))
- (function (_ reference instruction)
- (do random.monad
- [subject ..$Float::random]
- (float (reference subject)
+ literal ($_ _.and
+ (_.lift "DCONST_0" (double (:coerce java/lang/Double +0.0) /.dconst-0))
+ (_.lift "DCONST_1" (double (:coerce java/lang/Double +1.0) /.dconst-1))
+ (_.lift "LDC2_W/DOUBLE"
+ (do random.monad
+ [expected ..$Double::random]
+ (double expected (..$Double::literal expected)))))
+ arithmetic ($_ _.and
+ (_.lift "DADD" (binary (double/2 "jvm dadd" "jvm double +") /.dadd))
+ (_.lift "DSUB" (binary (double/2 "jvm dsub" "jvm double -") /.dsub))
+ (_.lift "DMUL" (binary (double/2 "jvm dmul" "jvm double *") /.dmul))
+ (_.lift "DDIV" (binary (double/2 "jvm ddiv" "jvm double /") /.ddiv))
+ (_.lift "DREM" (binary (double/2 "jvm drem" "jvm double %") /.drem))
+ (_.lift "DNEG" (unary (function (_ value)
+ ((double/2 "jvm dsub" "jvm double -")
+ value
+ (:coerce java/lang/Double +0.0)))
+ /.dneg)))
+ comparison (: (-> (Bytecode Any) (-> java/lang/Double java/lang/Double Bit) (Random Bit))
+ (function (_ instruction standard)
+ (do random.monad
+ [reference ..$Double::random
+ subject ..$Double::random
+ #let [expected (if (for {@.old
+ ("jvm deq" reference subject)
+
+ @.jvm
+ ("jvm double =" ("jvm object cast" reference) ("jvm object cast" subject))})
+ +0
+ (if (standard reference subject)
+ +1
+ -1))]]
+ (<| (..bytecode (|>> (:coerce Int) (i.= expected)))
(do /.monad
- [_ (..$Float::literal subject)]
- instruction)))))
- binary (: (-> (-> java/lang/Float java/lang/Float java/lang/Float)
- (Bytecode Any)
- (Random Bit))
- (function (_ reference instruction)
- (do random.monad
- [parameter ..$Float::random
- subject ..$Float::random]
- (float (reference parameter subject)
- (do /.monad
- [_ (..$Float::literal subject)
- _ (..$Float::literal parameter)]
- instruction)))))
- literal ($_ _.and
- (_.lift "FCONST_0" (float (host.double-to-float (:coerce java/lang/Double +0.0)) /.fconst-0))
- (_.lift "FCONST_1" (float (host.double-to-float (:coerce java/lang/Double +1.0)) /.fconst-1))
- (_.lift "FCONST_2" (float (host.double-to-float (:coerce java/lang/Double +2.0)) /.fconst-2))
- (_.lift "LDC_W/FLOAT"
- (do random.monad
- [expected ..$Float::random]
- (float expected (..$Float::literal expected)))))
- arithmetic ($_ _.and
- (_.lift "FADD" (binary (float/2 "jvm fadd" "jvm float +") /.fadd))
- (_.lift "FSUB" (binary (float/2 "jvm fsub" "jvm float -") /.fsub))
- (_.lift "FMUL" (binary (float/2 "jvm fmul" "jvm float *") /.fmul))
- (_.lift "FDIV" (binary (float/2 "jvm fdiv" "jvm float /") /.fdiv))
- (_.lift "FREM" (binary (float/2 "jvm frem" "jvm float %") /.frem))
- (_.lift "FNEG" (unary (function (_ value)
- ((float/2 "jvm fsub" "jvm float -")
- value
- (host.double-to-float (:coerce java/lang/Double +0.0))))
- /.fneg)))
- comparison (: (-> (Bytecode Any) (-> java/lang/Float java/lang/Float Bit) (Random Bit))
- (function (_ instruction standard)
- (do random.monad
- [reference ..$Float::random
- subject ..$Float::random
- #let [expected (if (for {@.old
- ("jvm feq" reference subject)
-
- @.jvm
- (<comparison> ("jvm object cast" reference) ("jvm object cast" subject))})
- +0
- (if (standard reference subject)
- +1
- -1))]]
- (<| (..bytecode (|>> (:coerce Int) (i.= expected)))
- (do /.monad
- [_ (..$Float::literal subject)
- _ (..$Float::literal reference)
- _ instruction
- _ /.i2l]
- ..$Long::wrap)))))
- comparison-standard (: (-> java/lang/Float java/lang/Float Bit)
- (function (_ reference subject)
- (for {@.old
- ("jvm fgt" subject reference)
-
- @.jvm
- ("jvm float <" ("jvm object cast" subject) ("jvm object cast" reference))})))
- comparison ($_ _.and
- (_.lift "FCMPL" (comparison /.fcmpl comparison-standard))
- (_.lift "FCMPG" (comparison /.fcmpg comparison-standard)))]
- ($_ _.and
- (<| (_.context "literal")
- literal)
- (<| (_.context "arithmetic")
- arithmetic)
- (<| (_.context "comparison")
- comparison)
- ))))
-
-(def: double
- Test
- (with-expansions [<comparison> (for {@.old "jvm deq"
- @.jvm "jvm double ="})]
- (let [double (: (-> java/lang/Double (Bytecode Any) (Random Bit))
- (function (_ expected bytecode)
- (<| (..bytecode (for {@.old
- (|>> (:coerce java/lang/Double) ("jvm deq" expected))
-
- @.jvm
- (|>> (:coerce java/lang/Double) "jvm object cast" (<comparison> ("jvm object cast" expected)))}))
- (do /.monad
- [_ bytecode]
- ..$Double::wrap))))
- unary (: (-> (-> java/lang/Double java/lang/Double) (Bytecode Any) (Random Bit))
- (function (_ reference instruction)
- (do random.monad
- [subject ..$Double::random]
- (double (reference subject)
- (do /.monad
- [_ (..$Double::literal subject)]
- instruction)))))
- binary (: (-> (-> java/lang/Double java/lang/Double java/lang/Double) (Bytecode Any) (Random Bit))
- (function (_ reference instruction)
- (do random.monad
- [parameter ..$Double::random
- subject ..$Double::random]
- (double (reference parameter subject)
- (do /.monad
- [_ (..$Double::literal subject)
- _ (..$Double::literal parameter)]
- instruction)))))
- literal ($_ _.and
- (_.lift "DCONST_0" (double (:coerce java/lang/Double +0.0) /.dconst-0))
- (_.lift "DCONST_1" (double (:coerce java/lang/Double +1.0) /.dconst-1))
- (_.lift "LDC2_W/DOUBLE"
- (do random.monad
- [expected ..$Double::random]
- (double expected (..$Double::literal expected)))))
- arithmetic ($_ _.and
- (_.lift "DADD" (binary (double/2 "jvm dadd" "jvm double +") /.dadd))
- (_.lift "DSUB" (binary (double/2 "jvm dsub" "jvm double -") /.dsub))
- (_.lift "DMUL" (binary (double/2 "jvm dmul" "jvm double *") /.dmul))
- (_.lift "DDIV" (binary (double/2 "jvm ddiv" "jvm double /") /.ddiv))
- (_.lift "DREM" (binary (double/2 "jvm drem" "jvm double %") /.drem))
- (_.lift "DNEG" (unary (function (_ value)
- ((double/2 "jvm dsub" "jvm double -")
- value
- (:coerce java/lang/Double +0.0)))
- /.dneg)))
- comparison (: (-> (Bytecode Any) (-> java/lang/Double java/lang/Double Bit) (Random Bit))
- (function (_ instruction standard)
- (do random.monad
- [reference ..$Double::random
- subject ..$Double::random
- #let [expected (if (for {@.old
- ("jvm deq" reference subject)
-
- @.jvm
- (<comparison> ("jvm object cast" reference) ("jvm object cast" subject))})
- +0
- (if (standard reference subject)
- +1
- -1))]]
- (<| (..bytecode (|>> (:coerce Int) (i.= expected)))
- (do /.monad
- [_ (..$Double::literal subject)
- _ (..$Double::literal reference)
- _ instruction
- _ /.i2l]
- ..$Long::wrap)))))
- ## https://docs.oracle.com/javase/specs/jvms/se7/html/jvms-6.html#jvms-6.5.dcmp_op
- comparison-standard (: (-> java/lang/Double java/lang/Double Bit)
- (function (_ reference subject)
- (for {@.old
- ("jvm dgt" subject reference)
-
- @.jvm
- ("jvm double <" ("jvm object cast" subject) ("jvm object cast" reference))})))
- comparison ($_ _.and
- (_.lift "DCMPL" (comparison /.dcmpl comparison-standard))
- (_.lift "DCMPG" (comparison /.dcmpg comparison-standard)))]
- ($_ _.and
- (<| (_.context "literal")
- literal)
- (<| (_.context "arithmetic")
- arithmetic)
- (<| (_.context "comparison")
- comparison)
- ))))
+ [_ (..$Double::literal subject)
+ _ (..$Double::literal reference)
+ _ instruction
+ _ /.i2l]
+ ..$Long::wrap)))))
+ ## https://docs.oracle.com/javase/specs/jvms/se7/html/jvms-6.html#jvms-6.5.dcmp_op
+ comparison-standard (: (-> java/lang/Double java/lang/Double Bit)
+ (function (_ reference subject)
+ (for {@.old
+ ("jvm dgt" subject reference)
+
+ @.jvm
+ ("jvm double <" ("jvm object cast" subject) ("jvm object cast" reference))})))
+ comparison ($_ _.and
+ (_.lift "DCMPL" (comparison /.dcmpl comparison-standard))
+ (_.lift "DCMPG" (comparison /.dcmpg comparison-standard)))]
+ ($_ _.and
+ (<| (_.context "literal")
+ literal)
+ (<| (_.context "arithmetic")
+ arithmetic)
+ (<| (_.context "comparison")
+ comparison)
+ )))
(def: primitive
Test
@@ -773,7 +772,8 @@
($_ _.and
(<| (_.lift "INVOKESTATIC")
(do random.monad
- [expected ..$Double::random])
+ [expected (random.filter (|>> (:coerce Frac) f.not-a-number? not)
+ ..$Double::random)])
(..bytecode (for {@.old
(|>> (:coerce java/lang/Double) ("jvm deq" expected))
@@ -793,7 +793,8 @@
..$Boolean::wrap))
(<| (_.lift "INVOKESPECIAL")
(do random.monad
- [expected ..$Double::random])
+ [expected (random.filter (|>> (:coerce Frac) f.not-a-number? not)
+ ..$Double::random)])
(..bytecode (for {@.old
(|>> (:coerce java/lang/Double) ("jvm deq" expected))
--
cgit v1.2.3