diff options
Diffstat (limited to '')
13 files changed, 391 insertions, 383 deletions
diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index 091d8e4a4..88bf45304 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -24,6 +24,7 @@ ["#." phase] [language [lux + [program (#+ Program)] ["#." version] ["#." syntax (#+ Aliases)] ["#." analysis @@ -58,7 +59,7 @@ (///generation.Phase anchor expression directive) (///generation.Bundle anchor expression directive) (///directive.Bundle anchor expression directive) - (-> expression directive) + (Program expression directive) Extender (///directive.State+ anchor expression directive))) (let [synthesis-state [synthesisE.bundle ///synthesis.init] diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 7813ba799..8faf83c46 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -30,6 +30,7 @@ ["#." phase] [language [lux + [program (#+ Program)] ["$" /] ["#." version] ["." syntax] @@ -89,16 +90,16 @@ (let [system (get@ #&file-system platform) write-artifact! (: (-> [Text Binary] (Action Any)) (function (_ [name content]) - (ioW.write system (get@ #static.host static) (get@ #static.target static) module-id name (get@ #static.artifact-extension static) content)))] + (ioW.write system static module-id name content)))] (do ..monad - [_ (ioW.prepare system (get@ #static.host static) (get@ #static.target static) module-id) + [_ (ioW.prepare system static module-id) _ (|> output row.to-list (monad.map ..monad write-artifact!) (: (Action (List Any)))) document (:: promise.monad wrap (document.check $.key document))] - (ioW.cache system (get@ #static.host static) (get@ #static.target static) module-id + (ioW.cache system static module-id (_.run ..writer [descriptor document]))))) ## TODO: Inline ASAP @@ -185,7 +186,7 @@ <Platform> <Bundle> (///directive.Bundle <type-vars>) - (-> expression directive) + (Program expression directive) Extender (Promise (Try [<State+> Archive])))) (do (try.with promise.monad) @@ -199,8 +200,8 @@ host-directive-bundle program extender)] - _ (ioW.enable (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static)) - [archive analysis-state bundles] (ioW.thaw (get@ #static.artifact-extension static) (get@ #host platform) (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static)) + _ (ioW.enable (get@ #&file-system platform) static) + [archive analysis-state bundles] (ioW.thaw (get@ #host platform) (get@ #&file-system platform) static) state (promise@wrap (initialize-state extender bundles analysis-state state))] (if (archive.archived? archive archive.runtime-module) (wrap [state archive]) @@ -430,7 +431,7 @@ (#try.Failure error) (do (try.with promise.monad) - [_ (ioW.freeze (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static) archive)] + [_ (ioW.freeze (get@ #&file-system platform) static archive)] (promise@wrap (#try.Failure error)))))))))]] (parallel-compiler compilation-module)))) )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux index 91de84cd1..6f3d288ef 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux @@ -31,8 +31,9 @@ [macro (#+ Expander)] ["#/." evaluation]] ["#." synthesis (#+ Synthesis)] - ["#." generation] + ["#." generation (#+ Context)] ["#." directive (#+ Import Requirements Phase Operation Handler Bundle)] + ["#." program (#+ Program)] [/// ["." phase] [meta @@ -339,7 +340,7 @@ ) ## TODO; Both "prepare-program" and "define-program" exist only -## because the old compiler couldn"t handle a fully-inlined definition +## because the old compiler couldn't handle a fully-inlined definition ## for "def::program". Inline them ASAP. (def: (prepare-program archive analyse synthesize programC) (All [anchor expression directive output] @@ -357,20 +358,22 @@ (/////directive.lift-synthesis (synthesize archive programA)))) -(def: (define-program archive generate program programS) +(def: (define-program archive module-id generate program programS) (All [anchor expression directive output] (-> Archive + archive.ID (/////generation.Phase anchor expression directive) - (-> expression directive) + (Program expression directive) Synthesis (/////generation.Operation anchor expression directive Any))) (do phase.monad - [programG (generate archive programS)] - (/////generation.save! false ["" ""] (program programG)))) + [artifact-id (/////generation.learn /////program.name) + programG (generate archive programS)] + (/////generation.save! false [(%.nat module-id) (%.nat artifact-id)] (program [module-id artifact-id] programG)))) (def: (def::program program) (All [anchor expression directive] - (-> (-> expression directive) (Handler anchor expression directive))) + (-> (Program expression directive) (Handler anchor expression directive))) (function (handler extension-name phase archive inputsC+) (case inputsC+ (^ (list programC)) @@ -380,8 +383,11 @@ synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) generate (get@ [#/////directive.generation #/////directive.phase] state)] programS (prepare-program archive analyse synthesize programC) + current-module (/////directive.lift-analysis + (///.lift macro.current-module-name)) + module-id (phase.lift (archive.id current-module archive)) _ (/////directive.lift-generation - (define-program archive generate program programS))] + (define-program archive module-id generate program programS))] (wrap /////directive.no-requirements)) _ @@ -391,7 +397,7 @@ (All [anchor expression directive] (-> Expander /////analysis.Bundle - (-> expression directive) + (Program expression directive) Extender (Bundle anchor expression directive))) (<| (///bundle.prefix "def") @@ -410,7 +416,7 @@ (All [anchor expression directive] (-> Expander /////analysis.Bundle - (-> expression directive) + (Program expression directive) Extender (Bundle anchor expression directive))) (<| (///bundle.prefix "lux") diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/packager.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/packager.lux deleted file mode 100644 index 95d3640b6..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/packager.lux +++ /dev/null @@ -1,110 +0,0 @@ -(.module: - [lux (#- Module Definition) - ["." host (#+ import: do-to)] - [data - ["." binary (#+ Binary)] - ["." text] - [number - ["n" nat]] - [collection - ["." row (#+ Row)] - ["." list ("#@." fold)]]] - [target - [jvm - [encoding - ["." name (#+ External)]]]]] - [// - [runtime (#+ Definition)] - [//// - [generation (#+ Buffer)] - [/// - [meta - [archive - [descriptor (#+ Module)]]]]]]) - -(import: #long java/lang/Object) - -(import: #long java/lang/String) - -(import: #long java/util/jar/Attributes - (put [java/lang/Object java/lang/Object] #? java/lang/Object)) - -(import: #long java/util/jar/Attributes$Name - (#static MAIN_CLASS java/util/jar/Attributes$Name) - (#static MANIFEST_VERSION java/util/jar/Attributes$Name)) - -(import: #long java/util/jar/Manifest - (new []) - (getMainAttributes [] java/util/jar/Attributes)) - -(import: #long java/io/Flushable - (flush [] void)) - -(import: #long java/io/Closeable - (close [] void)) - -(import: #long java/io/OutputStream) - -(import: #long java/io/ByteArrayOutputStream - (new [int]) - (toByteArray [] [byte])) - -(import: #long java/util/zip/ZipEntry) - -(import: #long java/util/zip/ZipOutputStream - (write [[byte] int int] void) - (closeEntry [] void)) - -(import: #long java/util/jar/JarEntry - (new [java/lang/String])) - -(import: #long java/util/jar/JarOutputStream - (new [java/io/OutputStream java/util/jar/Manifest]) - (putNextEntry [java/util/zip/ZipEntry] void)) - -(def: byte 1) -## https://en.wikipedia.org/wiki/Kibibyte -(def: kibi-byte (n.* 1,024 byte)) -## https://en.wikipedia.org/wiki/Mebibyte -(def: mebi-byte (n.* 1,024 kibi-byte)) - -(def: manifest-version "1.0") - -(def: class-name - (-> Text Text) - (text.suffix ".class")) - -(def: (manifest program-class) - (-> External java/util/jar/Manifest) - (let [manifest (java/util/jar/Manifest::new)] - (exec (do-to (java/util/jar/Manifest::getMainAttributes manifest) - (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MAIN_CLASS) program-class) - (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MANIFEST_VERSION) ..manifest-version)) - manifest))) - -(def: (write-class [def-name [class-name bytecode]] sink) - (-> [Name Definition] java/util/jar/JarOutputStream java/util/jar/JarOutputStream) - (let [class-name (|> class-name name.internal name.read ..class-name)] - (do-to sink - (java/util/jar/JarOutputStream::putNextEntry (java/util/jar/JarEntry::new class-name)) - (java/util/zip/ZipOutputStream::write bytecode +0 (.int (binary.size bytecode))) - (java/io/Flushable::flush) - (java/util/zip/ZipOutputStream::closeEntry)))) - -(def: (write-module [module classes] sink) - (-> [Module (Buffer Definition)] java/util/jar/JarOutputStream java/util/jar/JarOutputStream) - (|> classes - row.to-list - (list@fold ..write-class sink))) - -(def: #export (package program-class outputs) - (-> External (Row [Module (Buffer Definition)]) Binary) - (let [buffer (java/io/ByteArrayOutputStream::new (.int ..mebi-byte)) - sink (java/util/jar/JarOutputStream::new buffer (manifest program-class))] - (exec (|> outputs - row.to-list - (list@fold ..write-module sink)) - (do-to sink - (java/io/Flushable::flush) - (java/io/Closeable::close)) - (java/io/ByteArrayOutputStream::toByteArray buffer)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/program.lux b/stdlib/source/lux/tool/compiler/language/lux/program.lux new file mode 100644 index 000000000..6e5c93edf --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/program.lux @@ -0,0 +1,56 @@ +(.module: + [lux (#- Module) + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." maybe] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#@." functor)]]]] + [// + [generation (#+ Context)] + [/// + [meta + ["." archive (#+ Archive) + ["." descriptor (#+ Module)] + ["." artifact]]]]]) + +(type: #export (Program expression directive) + (-> Context expression directive)) + +(def: #export name + Text + "") + +(exception: #export (cannot-find-program {modules (List Module)}) + (exception.report + ["Modules" (exception.enumerate %.text modules)])) + +(def: #export (context archive) + (-> Archive (Try Context)) + (do {@ try.monad} + [registries (|> archive + archive.archived + (monad.map @ + (function (_ module) + (do @ + [id (archive.id module archive) + [descriptor document] (archive.find module archive)] + (wrap [[module id] (get@ #descriptor.registry descriptor)])))))] + (case (list.search (function (_ [[module module-id] registry]) + (do maybe.monad + [program-id (artifact.remember ..name registry)] + (wrap [module-id program-id]))) + registries) + (#.Some program-context) + (wrap program-context) + + #.None + (|> registries + (list@map (|>> product.left product.left)) + (exception.throw ..cannot-find-program))))) diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux index 3756e257a..827dfd013 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive.lux @@ -61,9 +61,12 @@ (exception.report ["Module" module])) -(type: #export ID Nat) +(type: #export ID + Nat) -(def: #export runtime-module Module "") +(def: #export runtime-module + Module + "") (abstract: #export Archive {} diff --git a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux index 911c2796b..d597541c9 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux @@ -20,7 +20,8 @@ [type abstract]]) -(type: #export ID Nat) +(type: #export ID + Nat) (type: #export Category #Anonymous diff --git a/stdlib/source/lux/tool/compiler/meta/cache.lux b/stdlib/source/lux/tool/compiler/meta/cache.lux deleted file mode 100644 index 72de6d285..000000000 --- a/stdlib/source/lux/tool/compiler/meta/cache.lux +++ /dev/null @@ -1,181 +0,0 @@ -(.module: - [lux (#- Module) - [control - ["." monad (#+ Monad do)] - ["." try] - ["ex" exception (#+ exception:)] - pipe] - [data - ["." bit ("#@." equivalence)] - ["." maybe] - ["." product] - [number - ["n" nat]] - [format - ["." binary (#+ Format)]] - ["." text - [format (#- Format)]] - [collection - ["." list ("#@." functor fold)] - ["dict" dictionary (#+ Dictionary)] - ["." set (#+ Set)]]] - [world - [file (#+ File System)]]] - ["." // - ["#." io (#+ Context Module) - ["#/." context] - ["#/." archive]] - ["#." archive (#+ Signature Key Descriptor Document Archive)] - ["#/" //]] - ["." / #_ - ["#." dependency (#+ Dependency Graph)]]) - -(exception: #export (cannot-delete-file {file File}) - (ex.report ["File" file])) - -(exception: #export (stale-document {module ///.Module} {current-hash Nat} {stale-hash Nat}) - (ex.report ["Module" module] - ["Current hash" (%n current-hash)] - ["Stale hash" (%n stale-hash)])) - -(exception: #export (mismatched-signature {module ///.Module} {expected Signature} {actual Signature}) - (ex.report ["Module" module] - ["Expected" (//archive.describe expected)] - ["Actual" (//archive.describe actual)])) - -(template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [cannot-load-definition] - ) - -## General -(def: #export (cached System<m> root) - (All [m] (-> (System m) File (m (List File)))) - (|> root - (//io/archive.archive System<m>) - (do> {@ (:: System<m> &monad)} - [(:: System<m> files)] - [(monad.map @ (function (recur file) - (do @ - [is-dir? (:: System<m> directory? file)] - (if is-dir? - (|> file - (do> @ - [(:: System<m> files)] - [(monad.map @ recur)] - [list.concat - (list& (maybe.assume (//io/archive.module System<m> root file))) - wrap])) - (wrap (list))))))] - [list.concat wrap]))) - -## Clean -(def: (delete System<m> document) - (All [m] (-> (System m) File (m Any))) - (do (:: System<m> &monad) - [deleted? (:: System<m> delete document)] - (if deleted? - (wrap []) - (:: System<m> throw cannot-delete-file document)))) - -(def: (un-install System<m> root module) - (All [m] (-> (System m) File Module (m Any))) - (let [document (//io/archive.document System<m> root module)] - (|> document - (do> {@ (:: System<m> &monad)} - [(:: System<m> files)] - [(monad.map @ (function (_ file) - (do @ - [? (:: System<m> directory? file)] - (if ? - (wrap #0) - (do @ - [_ (..delete System<m> file)] - (wrap #1))))))] - [(list.every? (bit@= #1)) - (if> [(..delete System<m> document)] - [(wrap [])])])))) - -(def: #export (clean System<m> root wanted-modules) - (All [m] (-> (System m) File (Set Module) (m Any))) - (|> root - (do> {@ (:: System<m> &monad)} - [(..cached System<m>)] - [(list.filter (bit.complement (set.member? wanted-modules))) - (monad.map @ (un-install System<m> root))]))) - -## Load -(def: signature - (Format Signature) - ($_ binary.and binary.name binary.text)) - -(def: descriptor - (Format Descriptor) - ($_ binary.and binary.nat binary.text (binary.list binary.text) (binary.ignore #.Cached))) - -(def: document - (All [a] (-> (Format a) (Format [Signature Descriptor a]))) - (|>> ($_ binary.and ..signature ..descriptor))) - -(def: (load-document System<m> contexts root key binary module) - (All [m d] (-> (System m) (List File) File (Key d) (Format d) Module - (m (Maybe [Dependency (Document d)])))) - (do {@ (:: System<m> &monad)} - [document' (:: System<m> read (//io/archive.document System<m> root module)) - [module' source-code] (//io/context.read System<m> contexts module) - #let [current-hash (:: text.hash hash source-code)]] - (case (do try.monad - [[signature descriptor content] (binary.read (..document binary) document') - #let [[document-hash _file references _state] descriptor] - _ (ex.assert mismatched-signature [module (get@ #//archive.signature key) signature] - (:: //archive.equivalence = - (get@ #//archive.signature key) - signature)) - _ (ex.assert stale-document [module current-hash document-hash] - (n.= current-hash document-hash)) - document (//archive.write key signature descriptor content)] - (wrap [[module references] document])) - (#try.Success [dependency document]) - (wrap (#.Some [dependency document])) - - (#try.Failure error) - (do @ - [_ (un-install System<m> root module)] - (wrap #.None))))) - -(def: #export (load-archive System<m> contexts root key binary) - (All [m d] (-> (System m) (List Context) File (Key d) (Format d) (m Archive))) - (do {@ (:: System<m> &monad)} - [candidate (|> root - (do> @ - [(..cached System<m>)] - [(monad.map @ (load-document System<m> contexts root key binary)) - (:: @ map (list@fold (function (_ full-document archive) - (case full-document - (#.Some [[module references] document]) - (dict.put module [references document] archive) - - #.None - archive)) - (: (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-entries) - candidate-archive (|> candidate-entries - (list@map (product.both id product.right)) - (dict.from-list text.hash)) - graph (|> candidate - dict.entries - (list@map (product.both id product.left)) - /dependency.graph - (/dependency.prune candidate-archive)) - archive (list@fold (function (_ module archive) - (if (dict.contains? module graph) - archive - (dict.remove module archive))) - candidate-archive - (dict.keys candidate))]] - (wrap archive))) diff --git a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux index 5a4dcef72..25c7065ca 100644 --- a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux +++ b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux @@ -90,8 +90,11 @@ (set.union new-batch))) ..fresh))))))))) +(type: #export Order + (List [Module [archive.ID [Descriptor (Document .Module)]]])) + (def: #export (load-order key archive) - (-> (Key .Module) Archive (Try (List [Module [archive.ID [Descriptor (Document .Module)]]]))) + (-> (Key .Module) Archive (Try Order)) (|> archive archive.archived (monad.map try.monad diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux index 0dbabd454..eef5907d2 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux @@ -23,6 +23,9 @@ ["." row (#+ Row)]]] [world ["." file (#+ Path File Directory)]]] + [program + [compositor + ["." static (#+ Static)]]] ["." // ["/#" // ["." archive (#+ Archive) @@ -48,108 +51,110 @@ ["Module ID" (%.nat module-id)] ["Error" error])) -(def: (archive system host root) - (-> (file.System Promise) Host Path Path) - (format root (:: system separator) host)) +(def: (archive system static) + (All [!] (-> (file.System !) Static Path)) + (format (get@ #static.target static) + (:: system separator) + (get@ #static.host static))) -(def: (unversioned-lux-archive system host root) - (-> (file.System Promise) Host Path Path) - (format (..archive system host root) +(def: (unversioned-lux-archive system static) + (All [!] (-> (file.System !) Static Path)) + (format (..archive system static) (:: system separator) //.lux-context)) -(def: (versioned-lux-archive system host root) - (-> (file.System Promise) Host Path Path) - (format (..unversioned-lux-archive system host root) +(def: (versioned-lux-archive system static) + (All [!] (-> (file.System !) Static Path)) + (format (..unversioned-lux-archive system static) (:: system separator) (%.nat ///.version))) -(def: (module system host root module-id) - (-> (file.System Promise) Host Path archive.ID Path) - (format (..versioned-lux-archive system host root) +(def: (module system static module-id) + (All [!] (-> (file.System !) Static archive.ID Path)) + (format (..versioned-lux-archive system static) (:: system separator) (%.nat module-id))) -(def: (artifact system host root module-id name extension) - (-> (file.System Promise) Host Path archive.ID Text Text Path) - (format (..module system host root module-id) +(def: #export (artifact system static module-id name) + (All [!] (-> (file.System !) Static archive.ID Text Path)) + (format (..module system static module-id) (:: system separator) name - extension)) + (get@ #static.artifact-extension static))) -(def: #export (prepare system host root module-id) - (-> (file.System Promise) Host Path archive.ID (Promise (Try Any))) +(def: #export (prepare system static module-id) + (-> (file.System Promise) Static archive.ID (Promise (Try Any))) (do {@ promise.monad} - [#let [module (..module system host root module-id)] + [#let [module (..module system static module-id)] module-exists? (file.exists? promise.monad system module)] (if module-exists? (wrap (#try.Success [])) (do @ - [_ (file.get-directory @ system (..unversioned-lux-archive system host root)) - _ (file.get-directory @ system (..versioned-lux-archive system host root)) + [_ (file.get-directory @ system (..unversioned-lux-archive system static)) + _ (file.get-directory @ system (..versioned-lux-archive system static)) outcome (!.use (:: system create-directory) module)] (case outcome (#try.Success output) (wrap (#try.Success [])) (#try.Failure error) - (wrap (exception.throw ..cannot-prepare [(..archive system host root) + (wrap (exception.throw ..cannot-prepare [(..archive system static) module-id error]))))))) -(def: #export (write system host root module-id name extension content) - (-> (file.System Promise) Host Path archive.ID Text Text Binary (Promise (Try Any))) +(def: #export (write system static module-id name content) + (-> (file.System Promise) Static archive.ID 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-id name extension)))] + (..artifact system static module-id name)))] (!.use (:: artifact over-write) content))) -(def: #export (enable system host root) - (-> (file.System Promise) Host Path (Promise (Try Any))) +(def: #export (enable system static) + (-> (file.System Promise) Static (Promise (Try Any))) (do (try.with promise.monad) [_ (: (Promise (Try (Directory Promise))) - (file.get-directory promise.monad system root)) + (file.get-directory promise.monad system (get@ #static.target static))) _ (: (Promise (Try (Directory Promise))) - (file.get-directory promise.monad system (..archive system host root)))] + (file.get-directory promise.monad system (..archive system static)))] (wrap []))) -(def: (general-descriptor system host root) - (-> (file.System Promise) Host Path Path) - (format (..archive system host root) +(def: (general-descriptor system static) + (-> (file.System Promise) Static Path) + (format (..archive system static) (:: system separator) "general-descriptor")) -(def: #export (freeze system host root archive) - (-> (file.System Promise) Host Path Archive (Promise (Try Any))) +(def: #export (freeze system static archive) + (-> (file.System Promise) Static Archive (Promise (Try Any))) (do (try.with promise.monad) [file (: (Promise (Try (File Promise))) - (file.get-file promise.monad system (..general-descriptor system host root)))] + (file.get-file promise.monad system (..general-descriptor system static)))] (!.use (:: file over-write) (archive.export ///.version archive)))) (def: module-descriptor-file "module-descriptor") -(def: (module-descriptor system host root module-id) - (-> (file.System Promise) Host Path archive.ID Path) - (format (..module system host root module-id) +(def: (module-descriptor system static module-id) + (-> (file.System Promise) Static archive.ID Path) + (format (..module system static module-id) (:: system separator) ..module-descriptor-file)) -(def: #export (cache system host root module-id content) - (-> (file.System Promise) Host Path archive.ID Binary (Promise (Try Any))) +(def: #export (cache system static module-id content) + (-> (file.System Promise) Static archive.ID Binary (Promise (Try Any))) (do (try.with promise.monad) [file (: (Promise (Try (File Promise))) (file.get-file promise.monad system - (..module-descriptor system host root module-id)))] + (..module-descriptor system static module-id)))] (!.use (:: file over-write) content))) -(def: (read-module-descriptor system host root module-id) - (-> (file.System Promise) Host Path archive.ID (Promise (Try Binary))) +(def: (read-module-descriptor system static module-id) + (-> (file.System Promise) Static archive.ID (Promise (Try Binary))) (do (try.with promise.monad) [file (: (Promise (Try (File Promise))) (file.get-file promise.monad system - (..module-descriptor system host root module-id)))] + (..module-descriptor system static module-id)))] (!.use (:: file content) []))) (def: parser @@ -173,10 +178,10 @@ (archive.archived archive)))] (wrap (set@ #.modules modules (fresh-analysis-state host))))) -(def: (cached-artifacts system host root module-id) - (-> (file.System Promise) Host Path archive.ID (Promise (Try (Dictionary Text Binary)))) +(def: (cached-artifacts system static module-id) + (-> (file.System Promise) Static archive.ID (Promise (Try (Dictionary Text Binary)))) (do {@ (try.with promise.monad)} - [module-dir (!.use (:: system directory) (..module system host root module-id)) + [module-dir (!.use (:: system directory) (..module system static module-id)) cached-files (!.use (:: module-dir files) [])] (|> cached-files (list@map (function (_ file) @@ -304,21 +309,21 @@ (wrap [(document.write $.key (set@ #.definitions definitions content)) bundles]))) -(def: (load-definitions system host root module-id extension host-environment [descriptor document]) +(def: (load-definitions system static module-id host-environment [descriptor document]) (All [expression directive] - (-> (file.System Promise) Host Path archive.ID Text (generation.Host expression directive) + (-> (file.System Promise) Static archive.ID (generation.Host expression directive) [Descriptor (Document .Module)] (Promise (Try [[Descriptor (Document .Module)] Bundles])))) (do (try.with promise.monad) - [actual (cached-artifacts system host root module-id) + [actual (cached-artifacts system static module-id) #let [expected (|> descriptor (get@ #descriptor.registry) artifact.artifacts)] - [document bundles] (promise@wrap (loaded-document extension host-environment module-id expected actual document))] + [document bundles] (promise@wrap (loaded-document (get@ #static.artifact-extension static) host-environment module-id expected actual document))] (wrap [[descriptor document] bundles]))) -(def: (load-every-reserved-module extension host-environment system host root archive) +(def: (load-every-reserved-module host-environment system static archive) (All [expression directive] - (-> Text (generation.Host expression directive) (file.System Promise) Host Path Archive + (-> (generation.Host expression directive) (file.System Promise) Static Archive (Promise (Try [Archive .Lux Bundles])))) @@ -327,7 +332,7 @@ archive.reservations (monad.map @ (function (_ [module-name module-id]) (do @ - [data (..read-module-descriptor system host root module-id) + [data (..read-module-descriptor system static module-id) descriptor,document (promise@wrap (<b>.run ..parser data))] (wrap [module-name [module-id descriptor,document]]))))) load-order (|> pre-loaded-caches @@ -340,7 +345,7 @@ promise@wrap) loaded-caches (monad.map @ (function (_ [module-name [module-id descriptor,document]]) (do @ - [[descriptor,document bundles] (..load-definitions system host root module-id extension host-environment descriptor,document)] + [[descriptor,document bundles] (..load-definitions system static module-id host-environment descriptor,document)] (wrap [[module-name descriptor,document] bundles]))) load-order)] @@ -351,7 +356,7 @@ (archive.add module descriptor,document archive)) archive loaded-caches) - analysis-state (..analysis-state host archive)] + analysis-state (..analysis-state (get@ #static.host static) archive)] (wrap [archive analysis-state (list@fold (function (_ [_ [+analysers +synthesizers +generators +directives]] @@ -363,22 +368,20 @@ ..empty-bundles loaded-caches)]))))) -(def: #export (thaw extension host-environment system host root) +(def: #export (thaw host-environment system static) (All [expression directive] - (-> Text (generation.Host expression directive) (file.System Promise) Host Path - (Promise (Try [Archive - .Lux - Bundles])))) + (-> (generation.Host expression directive) (file.System Promise) Static + (Promise (Try [Archive .Lux Bundles])))) (do promise.monad - [file (!.use (:: system file) (..general-descriptor system host root))] + [file (!.use (:: system file) (..general-descriptor system static))] (case file (#try.Success file) (do (try.with promise.monad) [binary (!.use (:: file content) []) archive (promise@wrap (archive.import ///.version binary))] - (..load-every-reserved-module extension host-environment system host root archive)) + (..load-every-reserved-module host-environment system static archive)) (#try.Failure error) (wrap (#try.Success [archive.empty - (fresh-analysis-state host) + (fresh-analysis-state (get@ #static.host static)) ..empty-bundles]))))) diff --git a/stdlib/source/lux/tool/compiler/meta/packager.lux b/stdlib/source/lux/tool/compiler/meta/packager.lux new file mode 100644 index 000000000..732ae18c0 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/packager.lux @@ -0,0 +1,42 @@ +(.module: + [lux #* + [abstract + [monad (#+ Monad)]] + [control + [try (#+ Try)]] + [data + [binary (#+ Binary)] + [collection + ["." row] + ["." list ("#@." functor)]]] + [world + ["." file (#+ Path)]]] + [program + [compositor + [static (#+ Static)]]] + [// + [cache + ["." dependency]] + ["." archive (#+ Archive) + ["." descriptor] + ["." artifact]] + [// + [language + [lux + [generation (#+ Context)]]]]]) + +(type: #export (Packager !) + (-> (Monad !) (file.System !) Static Archive Context (! (Try Binary)))) + +(type: #export Order + (List [archive.ID (List artifact.ID)])) + +(def: #export order + (-> dependency.Order Order) + (list@map (function (_ [module [module-id [descriptor document]]]) + (|> descriptor + (get@ #descriptor.registry) + artifact.artifacts + row.to-list + (list@map (|>> (get@ #artifact.id))) + [module-id])))) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/jvm.lux b/stdlib/source/lux/tool/compiler/meta/packager/jvm.lux new file mode 100644 index 000000000..7478a3bc2 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/packager/jvm.lux @@ -0,0 +1,159 @@ +(.module: + [lux (#- Module Definition) + [type (#+ :share)] + ["." host (#+ import: do-to)] + [abstract + ["." monad (#+ Monad do)]] + [control + ["." try (#+ Try)] + [concurrency + ["." promise (#+ Promise)]] + [security + ["!" capability]]] + [data + ["." binary (#+ Binary)] + ["." text + ["%" format (#+ format)]] + [number + ["n" nat]] + [collection + ["." row (#+ Row)] + ["." list ("#@." functor fold)]]] + [target + [jvm + [encoding + ["." name]]]] + [world + ["." file (#+ File Directory)]]] + [program + [compositor + ["." static (#+ Static)]]] + ["." // (#+ Packager) + [// + ["." archive + ["." descriptor (#+ Module)] + ["." artifact]] + ["." io #_ + ["#" archive]] + [// + [language + ["$" lux + [generation (#+ Context)] + [phase + [generation + [jvm + ["." runtime (#+ Definition)]]]]]]]]]) + +(import: #long java/lang/Object) + +(import: #long java/lang/String) + +(import: #long java/util/jar/Attributes + (put [java/lang/Object java/lang/Object] #? java/lang/Object)) + +(import: #long java/util/jar/Attributes$Name + (#static MAIN_CLASS java/util/jar/Attributes$Name) + (#static MANIFEST_VERSION java/util/jar/Attributes$Name)) + +(import: #long java/util/jar/Manifest + (new []) + (getMainAttributes [] java/util/jar/Attributes)) + +(import: #long java/io/Flushable + (flush [] void)) + +(import: #long java/io/Closeable + (close [] void)) + +(import: #long java/io/OutputStream) + +(import: #long java/io/ByteArrayOutputStream + (new [int]) + (toByteArray [] [byte])) + +(import: #long java/util/zip/ZipEntry) + +(import: #long java/util/zip/ZipOutputStream + (write [[byte] int int] void) + (closeEntry [] void)) + +(import: #long java/util/jar/JarEntry + (new [java/lang/String])) + +(import: #long java/util/jar/JarOutputStream + (new [java/io/OutputStream java/util/jar/Manifest]) + (putNextEntry [java/util/zip/ZipEntry] void)) + +(def: byte 1) +## https://en.wikipedia.org/wiki/Kibibyte +(def: kibi-byte (n.* 1,024 byte)) +## https://en.wikipedia.org/wiki/Mebibyte +(def: mebi-byte (n.* 1,024 kibi-byte)) + +(def: manifest-version "1.0") + +(def: (manifest program) + (-> Context java/util/jar/Manifest) + (let [manifest (java/util/jar/Manifest::new)] + (exec (do-to (java/util/jar/Manifest::getMainAttributes manifest) + (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MAIN_CLASS) (|> program runtime.class-name name.internal name.external)) + (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MANIFEST_VERSION) ..manifest-version)) + manifest))) + +## TODO: Delete ASAP +(type: (Action ! a) + (! (Try a))) + +(def: (write-class monad file-system static context sink) + (All [!] + (-> (Monad !) (file.System !) Static Context java/util/jar/JarOutputStream + (Action ! java/util/jar/JarOutputStream))) + (do (try.with monad) + [artifact (let [[module artifact] context] + (!.use (:: file-system file) [(io.artifact file-system static module (%.nat artifact))])) + content (!.use (:: artifact content) []) + #let [class-path (format (runtime.class-name context) (get@ #static.artifact-extension static))]] + (wrap (do-to sink + (java/util/jar/JarOutputStream::putNextEntry (java/util/jar/JarEntry::new class-path)) + (java/util/zip/ZipOutputStream::write content +0 (.int (binary.size content))) + (java/io/Flushable::flush) + (java/util/zip/ZipOutputStream::closeEntry))))) + +(def: (write-module monad file-system static [module artifacts] sink) + (All [!] + (-> (Monad !) (file.System !) Static [archive.ID (List artifact.ID)] java/util/jar/JarOutputStream + (Action ! java/util/jar/JarOutputStream))) + (monad.fold (:assume (try.with monad)) + (function (_ artifact sink) + (..write-class monad file-system static [module artifact] sink)) + sink + artifacts)) + +(def: #export (package monad file-system static archive program) + (All [!] (Packager !)) + (do {@ (try.with monad)} + [cache (:share [!] + {(Monad !) + monad} + {(! (Try (Directory !))) + (:assume (!.use (:: file-system directory) [(get@ #static.target static)]))}) + order (|> archive + archive.archived + (monad.map try.monad (function (_ module) + (do try.monad + [[descriptor document] (archive.find module archive) + module-id (archive.id module archive)] + (wrap (|> descriptor + (get@ #descriptor.registry) + artifact.artifacts + row.to-list + (list@map (|>> (get@ #artifact.id))) + [module-id]))))) + (:: monad wrap)) + #let [buffer (java/io/ByteArrayOutputStream::new (.int ..mebi-byte)) + sink (java/util/jar/JarOutputStream::new buffer (..manifest program))] + sink (monad.fold @ (..write-module monad file-system static) sink order) + #let [_ (do-to sink + (java/io/Flushable::flush) + (java/io/Closeable::close))]] + (wrap (java/io/ByteArrayOutputStream::toByteArray buffer)))) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index 63a73260d..dc8be4f83 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -3,7 +3,7 @@ [type (#+ :share)] ["@" target (#+ Host)] [abstract - [monad (#+ do)]] + [monad (#+ Monad do)]] [control ["." io (#+ IO io)] ["." try (#+ Try)] @@ -33,17 +33,21 @@ [default ["." platform (#+ Platform)]] [language - [lux + ["$" lux + ["#/." program (#+ Program)] ["." syntax] ["." analysis [macro (#+ Expander)]] - ["." generation (#+ Buffer)] + ["." generation (#+ Buffer Context)] ["." directive] [phase [extension (#+ Extender)]]]] [meta + [packager (#+ Packager)] [archive (#+ Archive) [descriptor (#+ Module)]] + [cache + ["." dependency]] [io ["ioW" archive]]]] ## ["." interpreter] @@ -68,6 +72,24 @@ (#try.Success output) (wrap output)))) +(def: (package! monad file-system [packager package] static archive context) + (All [!] (-> (Monad !) (file.System !) [Packager Path] Static Archive Context (! (Try Any)))) + (do (try.with monad) + [#let [packager (:share [!] {(Monad !) monad} {(Packager !) packager})] + content (packager monad file-system static archive context) + package (:share [!] + {(Monad !) + monad} + {(! (Try (File !))) + (:assume (file.get-file monad file-system package))})] + (!.use (:: (:share [!] + {(Monad !) + monad} + {(File !) + (:assume package)}) + over-write) + [content]))) + (with-expansions [<parameters> (as-is anchor expression artifact)] (def: #export (compiler static expander host-analysis platform generation-bundle host-directive-bundle program extender @@ -80,10 +102,10 @@ (IO (Platform <parameters>)) (generation.Bundle <parameters>) (directive.Bundle <parameters>) - (-> expression artifact) + (Program expression artifact) Extender Service - [(-> (Row [Module (generation.Buffer artifact)]) Binary) Path] + [Packager Path] (Promise Any))) (do {@ promise.monad} [platform (promise.future platform) @@ -106,7 +128,9 @@ platform} {(Promise (Try [Archive (directive.State+ <parameters>)])) (:assume (platform.compile compilation-libraries static expander platform compilation [archive state]))}) - _ (ioW.freeze (get@ #platform.&file-system platform) (get@ #/static.host static) (get@ #/static.target static) archive)] + _ (ioW.freeze (get@ #platform.&file-system platform) static archive) + program-context (promise@wrap ($/program.context archive)) + _ (promise.future (..package! io.monad file.system packager,package static archive program-context))] (wrap (log! "Compilation complete!")))) (#/cli.Export export) |