Generating module IDs in a similar way to artifact IDs.

3 files changed, 85 insertions, 22 deletions

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})