From a5e87f66c4588ac23201d00cc55a748b6088eb96 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 19 Apr 2020 00:25:35 -0400 Subject: Fixed artifact file-name generation and archive module naming in caching. --- new-luxc/source/luxc/lang/translation/jvm.lux | 7 +-- new-luxc/source/program.lux | 1 + stdlib/source/lux/control/function.lux | 6 ++- stdlib/source/lux/control/io.lux | 12 ++--- stdlib/source/lux/host.jvm.lux | 4 +- stdlib/source/lux/host.old.lux | 4 +- .../source/lux/tool/compiler/default/platform.lux | 22 ++++---- .../language/lux/phase/generation/jvm/runtime.lux | 5 +- stdlib/source/lux/tool/compiler/meta/cache.lux | 16 +++--- .../lux/tool/compiler/meta/cache/dependency.lux | 33 ++++++------ stdlib/source/lux/tool/compiler/meta/io.lux | 2 + .../source/lux/tool/compiler/meta/io/archive.lux | 46 ++++++++++------- stdlib/source/program/compositor.lux | 4 +- stdlib/source/test/lux/abstract/monoid.lux | 12 +++-- stdlib/source/test/lux/control.lux | 6 ++- stdlib/source/test/lux/control/function.lux | 58 ++++++++++++++++++++++ stdlib/source/test/lux/control/io.lux | 10 ++-- 17 files changed, 163 insertions(+), 85 deletions(-) create mode 100644 stdlib/source/test/lux/control/function.lux diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux index 569da0bd9..f98438902 100644 --- a/new-luxc/source/luxc/lang/translation/jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm.lux @@ -29,6 +29,7 @@ [lux ["." generation]]] [meta + [io (#+ lux-context)] [archive [descriptor (#+ Module)] ["." artifact]]]]]] @@ -97,13 +98,9 @@ (-> Text Text) (text.replace-all ..class-path-separator .module-separator)) -## TODO: This is a hackish solution to the issue I have. -## It should be cleaned up ASAP. -(def: prefix "lux.") - (def: #export (class-name [module-id artifact-id]) (-> generation.Context Text) - (format ..prefix (%.nat module-id) ..class-path-separator (%.nat artifact-id))) + (format lux-context "." (%.nat module-id) ..class-path-separator (%.nat artifact-id))) (def: (evaluate! library loader eval-class valueI) (-> Library ClassLoader Text Inst (Try [Any Definition])) diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux index 5fbbd0537..dc293cf81 100644 --- a/new-luxc/source/program.lux +++ b/new-luxc/source/program.lux @@ -163,5 +163,6 @@ jvm/program.program ..extender service + ".class" [(packager.package jvm/program.class) jar-path]) (io.io [])))) diff --git a/stdlib/source/lux/control/function.lux b/stdlib/source/lux/control/function.lux index ce999eb39..d9b8e36c5 100644 --- a/stdlib/source/lux/control/function.lux +++ b/stdlib/source/lux/control/function.lux @@ -5,7 +5,7 @@ (def: #export identity {#.doc (doc "Identity function." - "Does nothing to it's argument and just returns it." + "Does nothing to its argument and just returns it." (let [value "foo"] (is? (identity value) value)))} @@ -40,6 +40,8 @@ (-> i (-> i o) o)) (function input)) -(structure: #export monoid (All [a] (Monoid (-> a a))) +(structure: #export monoid + (All [a] (Monoid (-> a a))) + (def: identity ..identity) (def: compose ..compose)) diff --git a/stdlib/source/lux/control/io.lux b/stdlib/source/lux/control/io.lux index da93918c3..533e321b9 100644 --- a/stdlib/source/lux/control/io.lux +++ b/stdlib/source/lux/control/io.lux @@ -17,7 +17,7 @@ {#.doc "A type that represents synchronous, effectful computations that may interact with the outside world."} (-> Any a) - (def: #export (label thunk) + (def: (label thunk) (All [a] (-> (-> Any a) (IO a))) (:abstraction thunk)) @@ -26,7 +26,7 @@ (function (g!func g!arg) computation)))) - (template: (!execute io) + (template: (!run io) ## creatio ex nihilo ((:representation io) [])) @@ -47,22 +47,22 @@ (def: #export run {#.doc "A way to execute IO computations and perform their side-effects."} (All [a] (-> (IO a) a)) - (|>> !execute)) + (|>> !run)) (structure: #export functor (Functor IO) (def: (map f) - (|>> !execute f !io))) + (|>> !run f !io))) (structure: #export apply (Apply IO) (def: &functor ..functor) (def: (apply ff fa) - (!io ((!execute ff) (!execute fa))))) + (!io ((!run ff) (!run fa))))) (structure: #export monad (Monad IO) (def: &functor ..functor) (def: wrap (|>> !io)) - (def: join (|>> !execute !execute !io))) + (def: join (|>> !run !run !io))) ) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index b34cd4242..dad69604e 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -1379,9 +1379,7 @@ (#.Left error) (recover-from-failure error)))} - (with-gensyms [g!_] - (wrap (list (` ("lux try" ((~! io.label) (.function ((~ g!_) (~ g!_)) - (~ expression))))))))) + (wrap (list (` ("lux try" ((~! io.io) (~ expression))))))) (syntax: #export (check {#let [imports (..context *compiler*)]} {class (..type^ imports (list))} diff --git a/stdlib/source/lux/host.old.lux b/stdlib/source/lux/host.old.lux index c559d3555..e5a5b3624 100644 --- a/stdlib/source/lux/host.old.lux +++ b/stdlib/source/lux/host.old.lux @@ -1462,9 +1462,7 @@ (#.Left error) (recover-from-failure error)))} - (with-gensyms [g!_] - (wrap (list (` ("lux try" ((~! io.label) (.function ((~ g!_) (~ g!_)) - (~ expression))))))))) + (wrap (list (` ("lux try" ((~! io.io) (~ expression))))))) (syntax: #export (check {#let [imports (class-imports *compiler*)]} {class (generic-type^ imports (list))} diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index fa519d8a2..7419ddac5 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -57,17 +57,16 @@ (as-is (///directive.State+ anchor expression directive)) (as-is (///generation.Bundle anchor expression directive))] - (def: (cache-module platform host target-dir module-file-name module-name output ## module - ) + (def: (cache-module platform host target-dir module-file-name module-id extension output) (All - (-> Host Path Path Text Output ## Module + (-> Host Path Path archive.ID Text Output (Promise (Try Any)))) (let [system (get@ #&file-system platform) write-artifact! (: (-> [Text Binary] (Promise (Try Any))) (function (_ [name content]) - (ioW.write system host target-dir module-name name content)))] + (ioW.write system host target-dir module-id name extension content)))] (do (try.with promise.monad) - [_ (ioW.prepare system host target-dir module-name) + [_ (ioW.prepare system host target-dir module-id) _ (|> output row.to-list (monad.map promise.monad @@ -162,9 +161,9 @@ ## (io.fail error)) ) - (def: #export (compile target partial-host-extension expander platform host configuration archive state) + (def: #export (compile target partial-host-extension expander platform host configuration archive extension state) (All - (-> Text Text Expander Host Configuration Archive (Promise (Try [Archive ])))) + (-> Text Text Expander Host Configuration Archive Text (Promise (Try [Archive ])))) (let [source-module (get@ #cli.module configuration) compiler (:share { @@ -182,7 +181,7 @@ (Promise (Try [Archive ]))) recur})] (do (try.with promise.monad) - [[_module-id archive] (promise@wrap (archive.reserve module archive)) + [[module-id archive] (promise@wrap (archive.reserve module archive)) input (context.read (get@ #&file-system platform) (get@ #cli.sources configuration) partial-host-extension @@ -233,10 +232,9 @@ host target (get@ #///.file input) - module - output - ## module - )] + module-id + extension + output)] (case (archive.add module descriptor+document archive) (#try.Success archive) (wrap [archive state]) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux index 54c2f615a..e08a6219f 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux @@ -52,6 +52,7 @@ [arity (#+ Arity)] [reference (#+ Register)] [meta + [io (#+ lux-context)] [archive (#+ Archive)]]]]]]) (type: #export Byte-Code Binary) @@ -76,11 +77,9 @@ (type: #export Host (generation.Host (Bytecode Any) Definition)) -(def: prefix "lux/") - (def: #export (class-name [module id]) (-> generation.Context Text) - (format ..prefix (%.nat module) "/" (%.nat id))) + (format lux-context "/" (%.nat module) "/" (%.nat id))) (def: #export class (type.class "LuxRuntime" (list))) diff --git a/stdlib/source/lux/tool/compiler/meta/cache.lux b/stdlib/source/lux/tool/compiler/meta/cache.lux index bb4c4d8c8..fbf7fe128 100644 --- a/stdlib/source/lux/tool/compiler/meta/cache.lux +++ b/stdlib/source/lux/tool/compiler/meta/cache.lux @@ -6,7 +6,7 @@ ["ex" exception (#+ exception:)] pipe] [data - ["." bit ("#;." equivalence)] + ["." bit ("#@." equivalence)] ["." maybe] ["." product] [number @@ -16,7 +16,7 @@ ["." text [format (#- Format)]] [collection - ["." list ("#;." functor fold)] + ["." list ("#@." functor fold)] ["dict" dictionary (#+ Dictionary)] ["." set (#+ Set)]]] [world @@ -94,7 +94,7 @@ (do @ [_ (..delete System file)] (wrap #1))))))] - [(list.every? (bit;= #1)) + [(list.every? (bit@= #1)) (if> [(..delete System document)] [(wrap [])])])))) @@ -152,7 +152,7 @@ (do> @ [(..cached System)] [(monad.map @ (load-document System contexts root key binary)) - (:: @ map (list;fold (function (_ full-document archive) + (:: @ map (list@fold (function (_ full-document archive) (case full-document (#.Some [[module references] document]) (dict.put module [references document] archive) @@ -162,17 +162,17 @@ (: (Dictionary Text [(List Module) (Ex [d] (Document d))]) (dict.new text.hash))))])) #let [candidate-entries (dict.entries candidate) - candidate-dependencies (list;map (product.both id product.left) + candidate-dependencies (list@map (product.both id product.left) candidate-entries) candidate-archive (|> candidate-entries - (list;map (product.both id product.right)) + (list@map (product.both id product.right)) (dict.from-list text.hash)) graph (|> candidate dict.entries - (list;map (product.both id product.left)) + (list@map (product.both id product.left)) /dependency.graph (/dependency.prune candidate-archive)) - archive (list;fold (function (_ module archive) + archive (list@fold (function (_ module archive) (if (dict.contains? module graph) archive (dict.remove module archive))) diff --git a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux index ec01baf45..bb3736518 100644 --- a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux +++ b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux @@ -3,29 +3,32 @@ [data ["." text] [collection - ["." list ("#;." functor fold)] - ["dict" dictionary (#+ Dictionary)]]]] + ["." list ("#@." functor fold)] + ["." dictionary (#+ Dictionary)]]]] [///io (#+ Module)] [///archive (#+ Archive)]) -(type: #export Graph (Dictionary Module (List Module))) +(type: #export Graph + (Dictionary Module (List Module))) -(def: #export empty Graph (dict.new text.hash)) +(def: #export empty + Graph + (dictionary.new text.hash)) (def: #export (add to from) (-> Module Module Graph Graph) - (|>> (dict.update~ from (list) (|>> (#.Cons to))) - (dict.update~ to (list) id))) + (|>> (dictionary.update~ from (list) (|>> (#.Cons to))) + (dictionary.update~ to (list) id))) (def: dependents - (-> Module Graph (Maybe (List Text))) - dict.get) + (-> Module Graph (Maybe (List Module))) + dictionary.get) (def: #export (remove module dependency) (-> Module Graph Graph) (case (dependents module dependency) (#.Some dependents) - (list;fold remove (dict.remove module dependency) dependents) + (list@fold remove (dictionary.remove module dependency) dependents) #.None dependency)) @@ -36,18 +39,18 @@ (def: #export (dependency [module imports]) (-> Dependency Graph) - (list;fold (..add module) ..empty imports)) + (list@fold (..add module) ..empty imports)) (def: #export graph (-> (List Dependency) Graph) - (|>> (list;map ..dependency) - (list;fold dict.merge empty))) + (|>> (list@map ..dependency) + (list@fold dictionary.merge empty))) (def: #export (prune archive graph) (-> Archive Graph Graph) - (list;fold (function (_ module graph) - (if (dict.contains? module archive) + (list@fold (function (_ module graph) + (if (dictionary.contains? module archive) graph (..remove module graph))) graph - (dict.keys graph))) + (dictionary.keys graph))) diff --git a/stdlib/source/lux/tool/compiler/meta/io.lux b/stdlib/source/lux/tool/compiler/meta/io.lux index 579164881..271dcb79a 100644 --- a/stdlib/source/lux/tool/compiler/meta/io.lux +++ b/stdlib/source/lux/tool/compiler/meta/io.lux @@ -14,3 +14,5 @@ (def: #export (sanitize system) (All [m] (-> (System m) Text Text)) (text.replace-all "/" (:: system separator))) + +(def: #export lux-context "lux") diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux index abb8b75c6..2a5713f4f 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux @@ -16,56 +16,66 @@ ["%" format (#+ format)]]] [world ["." file (#+ Path File System)]]] - ["." // (#+ Module)]) + ["." // (#+ Module) + [// + ["." archive]]]) (exception: #export (cannot-prepare {archive Path} - {module Module} + {module-id archive.ID} {error Text}) (exception.report ["Archive" archive] - ["Module" module] + ["Module ID" (%.nat module-id)] ["Error" error])) (def: #export (archive system host root) (-> (System Promise) Host Path Path) (format root (:: system separator) host)) -(def: #export (document system host root module) - (-> (System Promise) Host Path Module Path) +(def: #export (lux-archive system host root) + (-> (System Promise) Host Path Path) (format (..archive system host root) (:: system separator) - (//.sanitize system module))) + //.lux-context)) + +(def: #export (document system host root module-id) + (-> (System Promise) Host Path archive.ID Path) + (format (..lux-archive system host root) + (:: system separator) + (%.nat module-id))) -(def: #export (artifact system host root module name) - (-> (System Promise) Host Path Module Text Path) - (format (document system host root module) +(def: #export (artifact system host root module-id name extension) + (-> (System Promise) Host Path archive.ID Text Text Path) + (format (document system host root module-id) (:: system separator) - (//.sanitize system name))) + name + extension)) -(def: #export (prepare system host root module) - (-> (System Promise) Host Path Module (Promise (Try Any))) +(def: #export (prepare system host root module-id) + (-> (System Promise) Host Path archive.ID (Promise (Try Any))) (do promise.monad - [#let [document (..document system host root module)] + [#let [document (..document system host root module-id)] document-exists? (file.exists? promise.monad system document)] (if document-exists? (wrap (#try.Success [])) (do @ - [outcome (!.use (:: system create-directory) document)] + [_ (file.get-directory @ system (..lux-archive system host root)) + outcome (!.use (:: system create-directory) document)] (case outcome (#try.Success output) (wrap (#try.Success [])) (#try.Failure error) (wrap (exception.throw ..cannot-prepare [(..archive system host root) - module + module-id error]))))))) -(def: #export (write system host root module name content) - (-> (System Promise) Host Path Module Text Binary (Promise (Try Any))) +(def: #export (write system host root module-id name extension content) + (-> (System Promise) Host Path archive.ID Text Text Binary (Promise (Try Any))) (do (try.with promise.monad) [artifact (: (Promise (Try (File Promise))) (file.get-file promise.monad system - (..artifact system host root module name)))] + (..artifact system host root module-id name extension)))] (!.use (:: artifact over-write) content))) (def: #export (module system host root document) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index 371dbdec7..5fb10d4ba 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -92,6 +92,7 @@ (def: #export (compiler target partial-host-extension expander host-analysis platform host generation-bundle host-directive-bundle program extender service + extension packager,package) (All [] (-> Path @@ -105,6 +106,7 @@ (-> expression artifact) Extender Service + Text [(-> (Row [Module (generation.Buffer artifact)]) Binary) Path] (Promise Any))) (do promise.monad @@ -126,7 +128,7 @@ {(Platform ) platform} {(Promise (Try [Archive (directive.State+ )])) - (platform.compile target partial-host-extension expander platform host configuration archive.empty state)}) + (platform.compile target partial-host-extension expander platform host configuration archive.empty extension state)}) ## _ (save-artifacts! (get@ #platform.&file-system platform) state packager,package) ## _ (cache/io.clean target ...) ] diff --git a/stdlib/source/test/lux/abstract/monoid.lux b/stdlib/source/test/lux/abstract/monoid.lux index b0f89abc7..5353e29cd 100644 --- a/stdlib/source/test/lux/abstract/monoid.lux +++ b/stdlib/source/test/lux/abstract/monoid.lux @@ -4,7 +4,7 @@ ["_" test (#+ Test)] [abstract/monad (#+ do)] [math - ["r" random (#+ Random)]] + ["." random (#+ Random)]] [control ["." function]]] {1 @@ -14,12 +14,18 @@ (def: #export (spec (^open "/@.") (^open "/@.") gen-sample) (All [a] (-> (Equivalence a) (Monoid a) (Random a) Test)) - (do r.monad - [sample gen-sample] + (do random.monad + [sample gen-sample + left gen-sample + mid gen-sample + right gen-sample] (<| (_.context (%.name (name-of /.Monoid))) ($_ _.and (_.test "Left identity." (/@= sample (/@compose /@identity sample))) (_.test "Right identity." (/@= sample (/@compose sample /@identity))) + (_.test "Associativity." + (/@= (/@compose left (/@compose mid right)) + (/@compose (/@compose left mid) right))) )))) diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index 169332b30..3a6491f25 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -4,8 +4,9 @@ ["." / #_ ["#." concatenative] ["#." continuation] - ["#." try] ["#." exception] + ["#." function] + ["#." try] ["#." io] ["#." parser] ["#." pipe] @@ -63,8 +64,9 @@ ($_ _.and /concatenative.test /continuation.test - /try.test /exception.test + /function.test + /try.test /io.test /parser.test /pipe.test diff --git a/stdlib/source/test/lux/control/function.lux b/stdlib/source/test/lux/control/function.lux new file mode 100644 index 000000000..f7d4d7678 --- /dev/null +++ b/stdlib/source/test/lux/control/function.lux @@ -0,0 +1,58 @@ +(.module: + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do)]] + [data + ["." name] + [number + ["n" nat]] + ["." text ("#@." equivalence) + ["%" format (#+ format)]]] + [math + ["." random (#+ Random)]] + ["_" test (#+ Test)]] + ["." /// #_ + [abstract + ["#." monoid]]] + {1 + ["." /]}) + +(def: #export test + Test + (do random.monad + [expected random.nat + f0 (:: @ map n.+ random.nat) + f1 (:: @ map n.* random.nat) + dummy random.nat + extra (|> random.nat (random.filter (|>> (n.= expected) not)))] + (<| (_.context (name.module (name-of /._))) + ($_ _.and + (let [equivalence (: (Equivalence (-> Nat Nat)) + (structure + (def: (= left right) + (n.= (left extra) + (right extra))))) + generator (: (Random (-> Nat Nat)) + (:: @ map n.- random.nat))] + (///monoid.spec equivalence /.monoid generator)) + + (_.test (%.name (name-of /.identity)) + (n.= expected + (/.identity expected))) + (_.test (%.name (name-of /.compose)) + (n.= (f0 (f1 expected)) + ((/.compose f0 f1) expected))) + (_.test (%.name (name-of /.constant)) + (n.= expected + ((/.constant expected) dummy))) + (_.test (%.name (name-of /.flip)) + (let [outcome ((/.flip n.-) expected extra)] + (and (n.= (n.- extra expected) + outcome) + (not (n.= (n.- expected extra) + outcome))))) + (_.test (%.name (name-of /.apply)) + (n.= (f0 extra) + (/.apply extra f0))) + )))) diff --git a/stdlib/source/test/lux/control/io.lux b/stdlib/source/test/lux/control/io.lux index fb5d3e67b..a0e5f7d4b 100644 --- a/stdlib/source/test/lux/control/io.lux +++ b/stdlib/source/test/lux/control/io.lux @@ -11,6 +11,7 @@ ["$." apply] ["$." monad]]}] [data + ["." name] [number ["n" nat]]]] {1 @@ -29,7 +30,7 @@ (def: #export test Test - (<| (_.context (%.name (name-of /.IO))) + (<| (_.context (name.module (name-of /._))) (do r.monad [sample r.nat exit-code r.int] @@ -38,8 +39,9 @@ ($apply.spec ..injection ..comparison /.apply) ($monad.spec ..injection ..comparison /.monad) - (_.test "Can execute computations designated as I/O computations." - (n.= sample (/.run (/.io sample)))) - (_.test "I/O operations won't execute unless they are explicitly run." + (_.test (%.name (name-of /.run)) + (n.= sample + (/.run (/.io sample)))) + (_.test (%.name (name-of /.exit)) (exec (/.exit exit-code) true)))))) -- cgit v1.2.3