From 4955cfe6f248a039e95b404f26abfae04204740f Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sat, 18 Apr 2020 04:10:45 -0400
Subject: Generating module IDs in a similar way to artifact IDs.

---
 .../source/lux/tool/compiler/default/platform.lux  |  3 +-
 .../lux/tool/compiler/language/lux/generation.lux  | 42 ++++++-----
 .../language/lux/phase/extension/directive/lux.lux |  7 +-
 .../lux/phase/extension/generation/jvm/host.lux    |  8 +-
 .../compiler/language/lux/phase/generation/jvm.lux |  2 +-
 .../language/lux/phase/generation/jvm/function.lux | 16 ++--
 .../phase/generation/jvm/function/method/new.lux   | 12 ++-
 .../lux/phase/generation/jvm/reference.lux         | 12 +--
 .../language/lux/phase/generation/jvm/runtime.lux  |  2 +-
 .../language/lux/phase/generation/reference.lux    |  2 +-
 stdlib/source/lux/tool/compiler/meta/archive.lux   | 85 +++++++++++++++++++---
 .../lux/tool/compiler/meta/archive/artifact.lux    | 16 ++--
 .../lux/tool/compiler/meta/archive/descriptor.lux  |  6 +-
 13 files changed, 146 insertions(+), 67 deletions(-)

(limited to 'stdlib/source')

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})
-- 
cgit v1.2.3