aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2020-04-18 04:10:45 -0400
committerEduardo Julian2020-04-18 04:10:45 -0400
commit4955cfe6f248a039e95b404f26abfae04204740f (patch)
treec86f33b80a6fe944e4aff78641f91bb66103bd91
parentae72864af3e95e46a042277873d38c3006361c79 (diff)
Generating module IDs in a similar way to artifact IDs.
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm.lux20
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/expression.lux2
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/extension/host.lux6
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/function.lux27
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/reference.lux16
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/runtime.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux3
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/generation.lux42
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux7
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux8
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux16
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive.lux85
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/artifact.lux16
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux6
19 files changed, 183 insertions, 105 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux
index 390b1497d..569da0bd9 100644
--- a/new-luxc/source/luxc/lang/translation/jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm.lux
@@ -25,6 +25,9 @@
["." descriptor]]]]
[tool
[compiler
+ [language
+ [lux
+ ["." generation]]]
[meta
[archive
[descriptor (#+ Module)]
@@ -98,14 +101,9 @@
## It should be cleaned up ASAP.
(def: prefix "lux.")
-(def: #export class-name'
- (-> Text Text)
- (|>> (text.replace-all .module-separator ..class-path-separator)
- (format ..prefix)))
-
-(def: #export (class-name module id)
- (-> Module artifact.ID Text)
- (format (..class-name' module) ..class-path-separator (%.nat id)))
+(def: #export (class-name [module-id artifact-id])
+ (-> generation.Context Text)
+ (format ..prefix (%.nat module-id) ..class-path-separator (%.nat artifact-id)))
(def: (evaluate! library loader eval-class valueI)
(-> Library ClassLoader Text Inst (Try [Any Definition]))
@@ -142,9 +140,9 @@
(loader.store class-name class-bytecode library))]
(loader.load class-name loader))))
-(def: (define! library loader module id valueI)
- (-> Library ClassLoader Module artifact.ID Inst (Try [Text Any Definition]))
- (let [class-name (..class-name module id)]
+(def: (define! library loader context valueI)
+ (-> Library ClassLoader generation.Context Inst (Try [Text Any Definition]))
+ (let [class-name (..class-name context)]
(do try.monad
[[value definition] (evaluate! library loader class-name valueI)]
(wrap [class-name value definition]))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/expression.lux b/new-luxc/source/luxc/lang/translation/jvm/expression.lux
index 441758fec..144e35f9b 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/expression.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/expression.lux
@@ -42,7 +42,7 @@
(structure.tuple translate archive members)
(^ (synthesis.variable variable))
- (reference.variable variable)
+ (reference.variable archive variable)
(^ (synthesis.constant constant))
(reference.constant archive constant)
diff --git a/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux b/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux
index cf039db68..408b2a389 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux
@@ -908,10 +908,10 @@
store-capturedI
_.RETURN))))
-(def: (anonymous-instance class env)
- (-> (Type Class) Environment (Operation Inst))
+(def: (anonymous-instance archive class env)
+ (-> Archive (Type Class) Environment (Operation Inst))
(do phase.monad
- [captureI+ (monad.map @ ///reference.variable env)]
+ [captureI+ (monad.map @ (///reference.variable archive) env)]
(wrap (|>> (_.NEW class)
_.DUP
(_.fuse captureI+)
diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.lux b/new-luxc/source/luxc/lang/translation/jvm/function.lux
index 449855aca..fa91b41df 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/function.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/function.lux
@@ -6,6 +6,9 @@
[pipe (#+ when> new>)]
["." function]]
[data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
[number
["n" nat]
["i" int]]
@@ -24,7 +27,9 @@
[lux
[analysis (#+ Environment)]
[synthesis (#+ Synthesis Abstraction Apply)]
- ["." generation]]]]]]
+ ["." generation]]]
+ [meta
+ [archive (#+ Archive)]]]]]
[luxc
[lang
[host
@@ -96,10 +101,10 @@
(list.repeat amount)
_.fuse))
-(def: (instance class arity env)
- (-> (Type Class) Arity Environment (Operation Inst))
+(def: (instance archive class arity env)
+ (-> Archive (Type Class) Arity Environment (Operation Inst))
(do phase.monad
- [captureI+ (monad.map @ reference.variable env)
+ [captureI+ (monad.map @ (reference.variable archive) env)
#let [argsI (if (poly-arg? arity)
(|> (nullsI (dec arity))
(list (_.int +0))
@@ -266,8 +271,8 @@
def.fuse)
function.identity))
-(def: #export (with-function @begin class env arity bodyI)
- (-> Label Text Environment Arity Inst
+(def: #export (with-function archive @begin class env arity bodyI)
+ (-> Archive Label Text Environment Arity Inst
(Operation [Def Inst]))
(let [classD (type.class class (list))
applyD (: Def
@@ -290,19 +295,19 @@
applyD
))]
(do phase.monad
- [instanceI (instance classD arity env)]
+ [instanceI (instance archive classD arity env)]
(wrap [functionD instanceI]))))
(def: #export (function generate archive [env arity bodyS])
(Generator Abstraction)
(do phase.monad
[@begin _.make-label
- [function-context bodyI] (generation.with-new-context
+ [function-context bodyI] (generation.with-new-context archive
(generation.with-anchor [@begin 1]
(generate archive bodyS)))
- #let [function-class (//runtime.class-name function-context)]
- [functionD instanceI] (with-function @begin function-class env arity bodyI)
- _ (generation.save! true ["" function-class]
+ #let [function-class (//.class-name function-context)]
+ [functionD instanceI] (with-function archive @begin function-class env arity bodyI)
+ _ (generation.save! true ["" (%.nat (product.right function-context))]
[function-class
(def.class #$.V1_6 #$.Public $.finalC
function-class (list)
diff --git a/new-luxc/source/luxc/lang/translation/jvm/reference.lux b/new-luxc/source/luxc/lang/translation/jvm/reference.lux
index ff5d7a96c..4eafecec0 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/reference.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/reference.lux
@@ -34,11 +34,11 @@
[partial-name "p"]
)
-(def: (foreign variable)
- (-> Register (Operation Inst))
+(def: (foreign archive variable)
+ (-> Archive Register (Operation Inst))
(do phase.monad
- [class-name (:: @ map //runtime.class-name
- generation.context)]
+ [class-name (:: @ map //.class-name
+ (generation.context archive))]
(wrap (|>> (_.ALOAD 0)
(_.GETFIELD (type.class class-name (list))
(|> variable .nat foreign-name)
@@ -48,18 +48,18 @@
(-> Register Inst)
(|>> _.ALOAD))
-(def: #export (variable variable)
- (-> Variable (Operation Inst))
+(def: #export (variable archive variable)
+ (-> Archive Variable (Operation Inst))
(case variable
(#reference.Local variable)
(operation@wrap (local variable))
(#reference.Foreign variable)
- (foreign variable)))
+ (foreign archive variable)))
(def: #export (constant archive name)
(-> Archive Name (Operation Inst))
(do phase.monad
- [class-name (:: @ map //runtime.class-name
+ [class-name (:: @ map //.class-name
(generation.remember archive name))]
(wrap (_.GETSTATIC (type.class class-name (list)) //.value-field //.$Value))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux
index 7d6c5427e..55c0aaab1 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux
@@ -29,10 +29,6 @@
["_" inst]]]]]
["." // (#+ ByteCode)])
-(def: #export (class-name [module id])
- (-> generation.Context Text)
- (//.class-name module id))
-
(def: $Text (type.class "java.lang.String" (list)))
(def: #export $Tag type.int)
(def: #export $Flag (type.class "java.lang.Object" (list)))
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index f51711289..fa519d8a2 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -182,7 +182,8 @@
(Promise (Try [Archive <State+>])))
recur})]
(do (try.with promise.monad)
- [input (context.read (get@ #&file-system platform)
+ [[_module-id archive] (promise@wrap (archive.reserve module archive))
+ input (context.read (get@ #&file-system platform)
(get@ #cli.sources configuration)
partial-host-extension
module)]
diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux
index 84f4f35d4..aedb38f61 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/generation.lux
@@ -11,6 +11,8 @@
["." name ("#@." equivalence)]
["." text ("#@." equivalence)
["%" format (#+ format)]]
+ [number
+ ["n" nat]]
[collection
["." row (#+ Row)]
["." list ("#@." functor)]]]]
@@ -25,6 +27,9 @@
["." descriptor (#+ Module)]
["." artifact]]]]])
+(type: #export Context [archive.ID artifact.ID])
+(type: #export (Buffer directive) (Row [Name directive]))
+
(exception: #export (cannot-interpret {error Text})
(exception.report
["Error" error]))
@@ -43,12 +48,9 @@
evaluate!)
(: (-> Text directive (Try Any))
execute!)
- (: (-> Module artifact.ID expression (Try [Text Any directive]))
+ (: (-> Context expression (Try [Text Any directive]))
define!))
-(type: #export (Buffer directive) (Row [Name directive]))
-(type: #export Context [Module artifact.ID])
-
(type: #export (State anchor expression directive)
{#module Module
#anchor (Maybe anchor)
@@ -168,11 +170,11 @@
[execute! directive]
)
-(def: #export (define! module id code)
+(def: #export (define! context code)
(All [anchor expression directive]
- (-> Module artifact.ID expression (Operation anchor expression directive [Text Any directive])))
+ (-> Context expression (Operation anchor expression directive [Text Any directive])))
(function (_ (^@ stateE [bundle state]))
- (case (:: (get@ #host state) define! module id code)
+ (case (:: (get@ #host state) define! context code)
(#try.Success output)
(#try.Success [stateE output])
@@ -192,11 +194,11 @@
(case ?buffer
(#.Some buffer)
(if (row.any? (|>> product.left (name@= name)) buffer)
- (phase.throw ..cannot-overwrite-output name)
+ (phase.throw ..cannot-overwrite-output [name])
(extension.update (set@ #buffer (#.Some (row.add [name code] buffer)))))
#.None
- (phase.throw ..no-buffer-for-saving-code name))))
+ (phase.throw ..no-buffer-for-saving-code [name]))))
(def: #export (learn name)
(All [anchor expression directive]
@@ -219,7 +221,8 @@
(function (_ (^@ stateE [bundle state]))
(let [[_module _name] name]
(do try.monad
- [registry (if (text@= (get@ #module state) _module)
+ [module-id (archive.id _module archive)
+ registry (if (text@= (get@ #module state) _module)
(#try.Success (get@ #registry state))
(do try.monad
[[descriptor document] (archive.find _module archive)]
@@ -229,20 +232,22 @@
(exception.throw ..unknown-definition [name (artifact.definitions registry)])
(#.Some id)
- (#try.Success [stateE [_module id]]))))))
+ (#try.Success [stateE [module-id id]]))))))
(exception: #export no-context)
-(def: #export context
+(def: #export (context archive)
(All [anchor expression directive]
- (Operation anchor expression directive Context))
+ (-> Archive (Operation anchor expression directive Context)))
(function (_ (^@ stateE [bundle state]))
(case (get@ #context state)
#.None
(exception.throw ..no-context [])
(#.Some id)
- (#try.Success [stateE [(get@ #module state) id]]))))
+ (do try.monad
+ [module-id (archive.id (get@ #module state) archive)]
+ (wrap [stateE [module-id id]])))))
(def: #export (with-context id body)
(All [anchor expression directive a]
@@ -255,16 +260,17 @@
(wrap [[bundle' (set@ #context (get@ #context state) state')]
output]))))
-(def: #export (with-new-context body)
+(def: #export (with-new-context archive body)
(All [anchor expression directive a]
- (-> (Operation anchor expression directive a)
+ (-> Archive (Operation anchor expression directive a)
(Operation anchor expression directive [Context a])))
(function (_ (^@ stateE [bundle state]))
(let [[id registry'] (artifact.resource (get@ #registry state))]
(do try.monad
[[[bundle' state'] output] (body [bundle (|> state
(set@ #registry registry')
- (set@ #context (#.Some id)))])]
+ (set@ #context (#.Some id)))])
+ module-id (archive.id (get@ #module state) archive)]
(wrap [[bundle' (set@ #context (get@ #context state) state')]
- [[(get@ #module state) id]
+ [[module-id id]
output]])))))
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 efceba1d9..d8cba75ff 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
@@ -36,7 +36,7 @@
[///
["." phase]
[meta
- [archive (#+ Archive)]]]]]])
+ ["." archive (#+ Archive)]]]]]])
(def: #export (custom [syntax handler])
(All [anchor expression directive s]
@@ -100,8 +100,9 @@
(do phase.monad
[codeG (generate archive codeS)
id (/////generation.learn name)
- [target-name value directive] (/////generation.define! module id codeG)
- _ (/////generation.save! false [module name] directive)]
+ module-id (phase.lift (archive.id module archive))
+ [target-name value directive] (/////generation.define! [module-id id] codeG)
+ _ (/////generation.save! false [(%.nat module-id) (%.nat id)] directive)]
(wrap [code//type codeG target-name value]))))
(def: (definition archive name expected codeC)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
index 3a7691134..266985b68 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
@@ -64,7 +64,7 @@
["#" phase]
["#." reference (#+ Variable)]
[meta
- [archive (#+ Archive)]]]]]])
+ ["." archive (#+ Archive)]]]]]])
(template [<name> <0> <1>]
[(def: <name>
@@ -943,10 +943,10 @@
store-capturedG
_.return)))))
-(def: (anonymous-instance class env)
- (-> (Type category.Class) Environment (Operation (Bytecode Any)))
+(def: (anonymous-instance archive class env)
+ (-> Archive (Type category.Class) Environment (Operation (Bytecode Any)))
(do //////.monad
- [captureG+ (monad.map @ ///reference.variable env)]
+ [captureG+ (monad.map @ (///reference.variable archive) env)]
(wrap ($_ _.compose
(_.new class)
_.dup
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux
index 38fd9fec8..b552f16d5 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux
@@ -39,7 +39,7 @@
(#synthesis.Reference reference)
(case reference
(#reference.Variable variable)
- (/reference.variable variable)
+ (/reference.variable archive variable)
(#reference.Constant constant)
(/reference.constant archive constant))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
index 891d74f71..7694b6b34 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
@@ -26,7 +26,11 @@
[pool (#+ Resource)]]
[encoding
["." name (#+ External Internal)]
- ["." unsigned]]]]]
+ ["." unsigned]]]]
+ [tool
+ [compiler
+ [meta
+ ["." archive (#+ Archive)]]]]]
["." / #_
["#." abstract]
[field
@@ -52,8 +56,8 @@
["." arity (#+ Arity)]
["." phase]]]]])
-(def: #export (with @begin class environment arity body)
- (-> Label External Environment Arity (Bytecode Any)
+(def: #export (with archive @begin class environment arity body)
+ (-> Archive Label External Environment Arity (Bytecode Any)
(Operation [(List (Resource Field))
(List (Resource Method))
(Bytecode Any)]))
@@ -72,7 +76,7 @@
(list& (/implementation.method arity @begin body)))
(list (/implementation.method' //runtime.apply::name arity @begin body)))))]
(do phase.monad
- [instance (/new.instance classT environment arity)]
+ [instance (/new.instance archive classT environment arity)]
(wrap [fields methods instance]))))
(def: modifier
@@ -93,11 +97,11 @@
(Generator Abstraction)
(do phase.monad
[@begin //runtime.forge-label
- [function-context bodyG] (generation.with-new-context
+ [function-context bodyG] (generation.with-new-context archive
(generation.with-anchor [@begin ..this-offset]
(generate archive bodyS)))
#let [function-class (//runtime.class-name function-context)]
- [fields methods instance] (..with @begin function-class environment arity bodyG)
+ [fields methods instance] (..with archive @begin function-class environment arity bodyG)
class (phase.lift (class.class version.v6_0
..modifier
(name.internal function-class)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux
index a307650dd..991745ff0 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux
@@ -16,7 +16,11 @@
["." constant
[pool (#+ Resource)]]
[type (#+ Type)
- ["." category (#+ Class Value Return)]]]]]
+ ["." category (#+ Class Value Return)]]]]
+ [tool
+ [compiler
+ [meta
+ ["." archive (#+ Archive)]]]]]
["." //
["#." init]
["#." implementation]
@@ -46,10 +50,10 @@
(///partial.new arity)
(_.invokespecial class //init.name (//init.type environment arity))))
-(def: #export (instance class environment arity)
- (-> (Type Class) Environment Arity (Operation (Bytecode Any)))
+(def: #export (instance archive class environment arity)
+ (-> Archive (Type Class) Environment Arity (Operation (Bytecode Any)))
(do phase.monad
- [foreign* (monad.map @ ////reference.variable environment)]
+ [foreign* (monad.map @ (////reference.variable archive) environment)]
(wrap (instance' foreign* class environment arity))))
(def: #export (method class environment arity)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
index 913b28793..d60f9a8b3 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
@@ -37,25 +37,25 @@
[partial-name "p"]
)
-(def: (foreign variable)
- (-> Register (Operation (Bytecode Any)))
+(def: (foreign archive variable)
+ (-> Archive Register (Operation (Bytecode Any)))
(do ////.monad
[bytecode-name (:: @ map //runtime.class-name
- generation.context)]
+ (generation.context archive))]
(wrap ($_ _.compose
..this
(_.getfield (type.class bytecode-name (list))
(..foreign-name variable)
//type.value)))))
-(def: #export (variable variable)
- (-> Variable (Operation (Bytecode Any)))
+(def: #export (variable archive variable)
+ (-> Archive Variable (Operation (Bytecode Any)))
(case variable
(#reference.Local variable)
(operation@wrap (_.aload variable))
(#reference.Foreign variable)
- (..foreign variable)))
+ (..foreign archive variable)))
(def: #export (constant archive name)
(-> Archive Name (Operation (Bytecode Any)))
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 14df69e42..54c2f615a 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
@@ -80,7 +80,7 @@
(def: #export (class-name [module id])
(-> generation.Context Text)
- (format ..prefix module "/" (%.nat id)))
+ (format ..prefix (%.nat module) "/" (%.nat id)))
(def: #export class (type.class "LuxRuntime" (list)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux
index 86fb57f0a..84efa7c50 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux
@@ -57,7 +57,7 @@
(def: #export (artifact-name [module id])
(-> Context Text)
- (format "lux_" "m" module "a" (%.nat id)))
+ (format "lux_" "m" (%.nat module) "a" (%.nat id)))
(def: #export (system constant variable)
(All [expression]
diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux
index edab30124..6db7cc0bb 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive.lux
@@ -8,9 +8,11 @@
["." exception (#+ exception:)]
["." function]]
[data
+ ["." product]
["." name]
["." text]
[collection
+ ["." list]
["." dictionary (#+ Dictionary)]]]
[type
abstract]
@@ -36,34 +38,83 @@
["Old key" (signature.description (document.signature old))]
["New key" (signature.description (document.signature new))]))
+(exception: #export (module-has-already-been-reserved {module Module})
+ (exception.report
+ ["Module" module]))
+
+(exception: #export (module-must-be-reserved-before-it-can-be-added {module Module})
+ (exception.report
+ ["Module" module]))
+
+(exception: #export (module-is-only-reserved {module Module})
+ (exception.report
+ ["Module" module]))
+
+(type: #export ID Nat)
+
(abstract: #export Archive
{}
- (Dictionary Module [Descriptor (Document Any)])
+ (Dictionary Module [ID (Maybe [Descriptor (Document Any)])])
(def: #export empty
Archive
(:abstraction (dictionary.new text.hash)))
+ (def: next
+ (-> Archive ID)
+ (|>> :representation dictionary.size))
+
+ (def: #export (id module archive)
+ (-> Module Archive (Try ID))
+ (case (dictionary.get module (:representation archive))
+ (#.Some [id _])
+ (#try.Success id)
+
+ #.None
+ (exception.throw ..unknown-document [module
+ (dictionary.keys (:representation archive))])))
+
+ (def: #export (reserve module archive)
+ (-> Module Archive (Try [ID Archive]))
+ (case (dictionary.get module (:representation archive))
+ (#.Some _)
+ (exception.throw ..module-has-already-been-reserved [module])
+
+ #.None
+ (let [id (..next archive)]
+ (#try.Success [id
+ (|> archive
+ :representation
+ (dictionary.put module [id #.None])
+ :abstraction)]))))
+
(def: #export (add module [descriptor document] archive)
(-> Module [Descriptor (Document Any)] Archive (Try Archive))
(case (dictionary.get module (:representation archive))
- (#.Some [existing-descriptor existing-document])
+ (#.Some [id #.None])
+ (#try.Success (|> archive
+ :representation
+ (dictionary.put module [id (#.Some [descriptor document])])
+ :abstraction))
+
+ (#.Some [id (#.Some [existing-descriptor existing-document])])
(if (is? document existing-document)
+ ## TODO: Find out why this code allows for the same module to be added more than once. It looks fishy...
(#try.Success archive)
- (exception.throw cannot-replace-document [module existing-document document]))
+ (exception.throw ..cannot-replace-document [module existing-document document]))
#.None
- (#try.Success (|> archive
- :representation
- (dictionary.put module [descriptor document])
- :abstraction))))
+ (exception.throw ..module-must-be-reserved-before-it-can-be-added [module])))
(def: #export (find module archive)
(-> Module Archive (Try [Descriptor (Document Any)]))
(case (dictionary.get module (:representation archive))
- (#.Some document)
+ (#.Some [id (#.Some document)])
(#try.Success document)
+
+ (#.Some [id #.None])
+ (exception.throw ..module-is-only-reserved [module])
#.None
(exception.throw ..unknown-document [module
@@ -80,13 +131,25 @@
(def: #export archived
(-> Archive (List Module))
- (|>> :representation dictionary.keys))
+ (|>> :representation
+ dictionary.entries
+ (list.search-all (function (_ [module [id descriptor+document]])
+ (case descriptor+document
+ (#.Some _) (#.Some module)
+ #.None #.None)))))
(def: #export (merge additions archive)
(-> Archive Archive (Try Archive))
(monad.fold try.monad
- (function (_ [module' descriptor+document'] archive')
- (..add module' descriptor+document' archive'))
+ (function (_ [module' [id descriptor+document']] archive')
+ (case descriptor+document'
+ (#.Some descriptor+document')
+ (if (archived? archive' module')
+ (#try.Success archive')
+ (..add module' descriptor+document' archive'))
+
+ #.None
+ (#try.Success archive')))
archive
(dictionary.entries (:representation additions))))
)
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
index 256c10a22..2d4559275 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
@@ -17,34 +17,34 @@
(abstract: #export Registry
{}
- {#next ID
- #artifacts (Row Artifact)
+ {#artifacts (Row Artifact)
#resolver (Dictionary Text ID)}
(def: #export empty
Registry
- (:abstraction {#next 0
- #artifacts row.empty
+ (:abstraction {#artifacts row.empty
#resolver (dictionary.new text.hash)}))
+ (def: next
+ (-> Registry ID)
+ (|>> :representation (get@ #artifacts) row.size))
+
(def: #export (resource registry)
(-> Registry [ID Registry])
- (let [id (get@ #next (:representation registry))]
+ (let [id (..next registry)]
[id
(|> registry
:representation
- (update@ #next inc)
(update@ #artifacts (row.add {#id id
#name #.None}))
:abstraction)]))
(def: #export (definition name registry)
(-> Text Registry [ID Registry])
- (let [id (get@ #next (:representation registry))]
+ (let [id (..next registry)]
[id
(|> registry
:representation
- (update@ #next inc)
(update@ #artifacts (row.add {#id id
#name (#.Some name)}))
(update@ #resolver (dictionary.put name id))
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux
index 4582ab702..c6e1e7841 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux
@@ -11,9 +11,9 @@
(type: #export Module Text)
(type: #export Descriptor
- {#hash Nat
- #name Module
+ {#name Module
#file Path
- #references (Set Module)
+ #hash Nat
#state Module-State
+ #references (Set Module)
#registry Registry})