diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/data/env.lux | 25 | ||||
| -rw-r--r-- | stdlib/source/lux/data/identity.lux | 19 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/bytecode.lux | 76 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/default/platform.lux | 183 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/language/lux/directive.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/program/aedifex/artifact.lux | 9 | ||||
| -rw-r--r-- | stdlib/source/program/aedifex/dependency.lux | 8 | ||||
| -rw-r--r-- | stdlib/source/program/aedifex/format.lux | 153 | ||||
| -rw-r--r-- | stdlib/source/program/aedifex/parser.lux | 23 | ||||
| -rw-r--r-- | stdlib/source/program/aedifex/profile.lux | 89 | ||||
| -rw-r--r-- | stdlib/source/program/aedifex/project.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/spec/lux/abstract/comonad.lux | 61 | ||||
| -rw-r--r-- | stdlib/source/test/aedifex.lux | 21 | ||||
| -rw-r--r-- | stdlib/source/test/aedifex/parser.lux | 212 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/identity.lux | 26 | ||||
| -rw-r--r-- | stdlib/source/test/lux/target/jvm.lux | 621 |
16 files changed, 1109 insertions, 429 deletions
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)) |