aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2020-06-28 19:58:12 -0400
committerEduardo Julian2020-06-28 19:58:12 -0400
commitec29b735396a656862ab9dcdde3627e234c938b0 (patch)
treed10afd930c5714480226d182582fef2a71839ba9 /stdlib/source
parentaa42fde49c66d73f41b17d4939a9226671442a8a (diff)
Re-added & u[dated packaging machinery.
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/tool/compiler/default/init.lux3
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux15
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux26
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/packager.lux110
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/program.lux56
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive.lux7
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/artifact.lux3
-rw-r--r--stdlib/source/lux/tool/compiler/meta/cache.lux181
-rw-r--r--stdlib/source/lux/tool/compiler/meta/cache/dependency.lux5
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io/archive.lux131
-rw-r--r--stdlib/source/lux/tool/compiler/meta/packager.lux42
-rw-r--r--stdlib/source/lux/tool/compiler/meta/packager/jvm.lux159
-rw-r--r--stdlib/source/program/compositor.lux36
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)