- Some improvements to Index.

- Some improvements to Constant.
- Some improvements to Pool.
- WIP: Attribute

5 files changed, 149 insertions, 96 deletions

diff --git a/stdlib/source/lux/host/jvm.lux b/stdlib/source/lux/host/jvm.lux
index cc2216502..b8139760c 100644
--- a/stdlib/source/lux/host/jvm.lux
+++ b/stdlib/source/lux/host/jvm.lux
@@ -1,22 +1,26 @@
 (.module:
   [lux #*
+   [control
+    ["." monad (#+ do)]
+    ["." state (#+ State)]]
    [data
     [format
      ["." binary (#+ Format)]]
     [collection
-     [list ("list/." Fold<List>)]
      ["." row (#+ Row)]]]]
   [/
    ["/." version (#+ Version Minor Major)]
    ["/." name (#+ Internal)]
+   ["/." magic (#+ Magic)]
+   ["/." index (#+ Index)]
+   ["/." attribute (#+ Attribute)]
    [modifier
     ["/.M" class]]
-   ["/." magic (#+ Magic)]
-   ["/." constant (#+ Constant)]
-   ["/." index (#+ Index)]])
+   ["/." constant (#+ Constant)
+    ["/." pool (#+ Pool)]]])
 
 (type: #export Interface
-  Index)
+  (Index /constant.Class))
 
 (type: #export Field
   Any)
@@ -24,19 +28,14 @@
 (type: #export Method
   Any)
 
-(type: #export Attribute
-  Any)
-
-(type: #export Pool (Row Constant))
-
 (type: #export Class
   {#magic Magic
    #minor-version Minor
    #major-version Major
    #constant-pool Pool
    #access-flags /classM.Modifier
-   #this Index
-   #super Index
+   #this (Index /constant.Class)
+   #super (Index /constant.Class)
    #interfaces (Row Interface)
    #fields (Row Field)
    #methods (Row Method)
@@ -44,38 +43,32 @@
 
 (def: default-minor-version Minor (/version.version 0))
 
+(def: (install-classes this super interfaces)
+  (-> Internal Internal (List Internal)
+      (State Pool [(Index /constant.Class) (Index /constant.Class) (Row Interface)]))
+  (do state.Monad<State>
+    [@this (/pool.class (/name.read this))
+     @super (/pool.class (/name.read super))
+     @interfaces (monad.fold @ (function (_ interface @interfaces)
+                                 (do @
+                                   [@interface (/pool.class (/name.read interface))]
+                                   (wrap (row.add @interface @interfaces))))
+                             (: (Row Interface) row.empty)
+                             interfaces)]
+    (wrap [@this @super @interfaces])))
+
 (def: #export (class version access super this interfaces)
   (-> Major /classM.Modifier Internal Internal (List Internal) Class)
-  (let [with-classes (: (-> Pool Pool)
-                        (|>> (row.add (#/constant.UTF8 (/name.read this)))
-                             (row.add (#/constant.Class (/index.index 1)))
-                             (row.add (#/constant.UTF8 (/name.read super)))
-                             (row.add (#/constant.Class (/index.index 3)))))
-        with-interfaces (: (-> Nat Pool [(Row Index) Pool])
-                           (function (_ offset pool)
-                             (let [[_last-index indices pool']
-                                   (list/fold (function (_ interface [index interface-indices' pool'])
-                                                [(n/+ 2 index)
-                                                 (row.add (/index.index (n/+ 1 index))
-                                                          interface-indices')
-                                                 (|> pool'
-                                                     (row.add (#/constant.UTF8 (/name.read interface)))
-                                                     (row.add (#/constant.Class (/index.index index))))])
-                                              [offset (: (Row Index) row.empty) pool]
-                                              interfaces)]
-                               [indices pool'])))
-        interfaces-offset 5
-        [interface-indices pool] (|> row.empty
-                                     with-classes
-                                     (with-interfaces interfaces-offset))]
+  (let [[pool [@this @super @interfaces]] (state.run (: Pool row.empty)
+                                                     (install-classes this super interfaces))]
     {#magic /magic.code
      #minor-version ..default-minor-version
      #major-version version
      #constant-pool pool
      #access-flags access
-     #this (/index.index 2)
-     #super (/index.index 4)
-     #interfaces interface-indices
+     #this @this
+     #super @super
+     #interfaces @interfaces
      #fields row.empty
      #methods row.empty
      #attributes row.empty}))
@@ -86,7 +79,7 @@
       /magic.format
       /version.format
       /version.format
-      (binary.row/16' 1 /constant.format)
+      /pool.format
       /classM.format
       /index.format
       /index.format
diff --git a/stdlib/source/lux/host/jvm/attribute.lux b/stdlib/source/lux/host/jvm/attribute.lux
new file mode 100644
index 000000000..3f0dd9b61
--- /dev/null
+++ b/stdlib/source/lux/host/jvm/attribute.lux
@@ -0,0 +1,22 @@
+(.module:
+  [lux #*
+   [data
+    [format
+     ["." binary (#+ Format)]]]]
+  [//
+   ["//." encoding (#+ U2 U4)]
+   ["//." index (#+ Index)]])
+
+(type: #export Constant-Value
+  {#name Index
+   #length U4
+   #index Index})
+
+(def: #export constant-value
+  ($_ binary.and
+      //index.format
+      //encoding.u4-format
+      //index.format))
+
+(type: #export Attribute
+  Any)
diff --git a/stdlib/source/lux/host/jvm/constant.lux b/stdlib/source/lux/host/jvm/constant.lux
index d20e34d31..d2c9018ae 100644
--- a/stdlib/source/lux/host/jvm/constant.lux
+++ b/stdlib/source/lux/host/jvm/constant.lux
@@ -2,7 +2,8 @@
   [lux #*
    [control
     [monad (#+ do)]
-    ["." parser]]
+    ["." parser]
+    ["." equivalence (#+ Equivalence)]]
    [data
     [format
      ["." binary (#+ Format) ("mutation/." Monoid<Mutation>)]]
@@ -15,14 +16,42 @@
   [/
    ["/." tag ("tag/." Equivalence<Tag>)]])
 
+(type: #export UTF8 Text)
+
+(def: utf8-format
+  (Format UTF8)
+  binary.utf8/16)
+
+(abstract: #export Class
+  {}
+  
+  (Index UTF8)
+  
+  (def: #export class
+    (-> (Index UTF8) Class)
+    (|>> :abstraction))
+
+  (def: #export Equivalence<Class>
+    (Equivalence Class)
+    (:: equivalence.Contravariant<Equivalence> map-1
+        (|>> :representation)
+        //index.Equivalence<Index>))
+
+  (def: class-format
+    (Format Class)
+    (binary.adapt (|>> :abstraction)
+                  (|>> :representation)
+                  //index.format))
+  )
+
 (type: #export Constant
-  (#UTF8 Text)
-  (#Class Index))
+  (#UTF8 UTF8)
+  (#Class Class))
 
 (def: #export format
   (Format Constant)
-  (with-expansions [<constants> (as-is [#UTF8  /tag.utf8  binary.utf8/16]
-                                       [#Class /tag.class //index.format])]
+  (with-expansions [<constants> (as-is [#UTF8  /tag.utf8  ..utf8-format]
+                                       [#Class /tag.class ..class-format])]
     {#binary.reader (do parser.Monad<Parser>
                       [tag (get@ #binary.reader /tag.format)]
                       (`` (cond (~~ (do-template [<case> <tag> <format>]
diff --git a/stdlib/source/lux/host/jvm/constant/pool.lux b/stdlib/source/lux/host/jvm/constant/pool.lux
index 8d221712b..b21477b61 100644
--- a/stdlib/source/lux/host/jvm/constant/pool.lux
+++ b/stdlib/source/lux/host/jvm/constant/pool.lux
@@ -1,67 +1,60 @@
 (.module:
   [lux #*
+   [control
+    [monad (#+ do)]
+    ["." state (#+ State)]]
    [data
     [text ("text/." Equivalence<Text>)]
     [format
      ["." binary (#+ Format)]]
     [collection
      [list ("list/." Fold<List>)]
-     ["." row (#+ Row)]]]]
-  ["." // (#+ Constant)
+     ["." row (#+ Row)]]]
+   [type
+    abstract]]
+  ["." // (#+ UTF8 Class Constant) ("class/." Equivalence<Class>)
    [//
-    ["." encoding ("u2/." Equivalence<U2>)]
+    ["." encoding]
     ["." index (#+ Index)]]])
 
 (def: offset 1)
 
 (type: #export Pool (Row Constant))
 
-(def: #export (utf8 value pool)
-  (-> Text Pool [Pool Index])
-  (with-expansions [<index> (as-is (index.index (n/+ offset idx)))
-                    <try-again> (as-is (recur (.inc idx)))]
-    (loop [idx 0]
-      (case (row.nth idx pool)
-        (#.Some entry)
-        (case entry
-          (#//.UTF8 reference)
-          (if (text/= reference value)
-            [pool
-             <index>]
+(template: (!add <value> <tag> <=>)
+  (function (_ pool)
+    (with-expansions [<index> (as-is (index.index (encoding.to-u2 (n/+ offset idx))))
+                      <try-again> (as-is (recur (.inc idx)))]
+      (loop [idx 0]
+        (case (row.nth idx pool)
+          (#.Some entry)
+          (case entry
+            (<tag> reference)
+            (if (<=> reference <value>)
+              [pool
+               <index>]
+              <try-again>)
+            
+            _
             <try-again>)
           
-          _
-          <try-again>)
-        
-        #.None
-        [(row.add (#//.UTF8 value) pool)
-         <index>]))))
+          #.None
+          [(row.add (<tag> <value>) pool)
+           <index>])))))
 
-(def: (class' value pool)
-  (-> Index Pool [Pool Index])
-  (with-expansions [<index> (as-is (index.index (n/+ offset idx)))
-                    <try-again> (as-is (recur (.inc idx)))]
-    (loop [idx 0]
-      (case (row.nth idx pool)
-        (#.Some entry)
-        (case entry
-          (#//.Class reference)
-          (if (u2/= reference value)
-            [pool
-             <index>]
-            <try-again>)
-          
-          _
-          <try-again>)
-        
-        #.None
-        [(row.add (#//.Class value) pool)
-         <index>]))))
+(def: #export (utf8 value)
+  (-> UTF8 (State Pool (Index UTF8)))
+  (!add value #//.UTF8 text/=))
+
+(def: (class' value)
+  (-> Class (State Pool (Index Class)))
+  (!add value #//.Class class/=))
 
-(def: #export (class name pool)
-  (-> Text Pool [Pool Index])
-  (let [[pool @name] (utf8 name pool)]
-    (class' @name pool)))
+(def: #export (class name)
+  (-> UTF8 (State Pool (Index Class)))
+  (do state.Monad<State>
+    [@name (utf8 name)]
+    (class' (//.class @name))))
 
 (def: #export format
   (Format Pool)
diff --git a/stdlib/source/lux/host/jvm/index.lux b/stdlib/source/lux/host/jvm/index.lux
index 60d6211c6..3bf7e150b 100644
--- a/stdlib/source/lux/host/jvm/index.lux
+++ b/stdlib/source/lux/host/jvm/index.lux
@@ -1,17 +1,33 @@
 (.module:
   [lux #*
+   [control
+    ["." equivalence (#+ Equivalence)]]
    [data
     [format
-     [binary (#+ Format)]]]]
+     ["." binary (#+ Format)]]]
+   [type
+    abstract]]
   [//
    ["//." encoding (#+ U2)]])
 
-(type: #export Index U2)
+(abstract: #export (Index kind)
+  {}
 
-(def: #export index
-  (-> Nat Index)
-  //encoding.to-u2)
+  U2
 
-(def: #export format
-  (Format Index)
-  //encoding.u2-format)
+  (def: #export index
+    (All [kind] (-> U2 (Index kind)))
+    (|>> :abstraction))
+
+  (def: #export Equivalence<Index>
+    (All [kind] (Equivalence (Index kind)))
+    (:: equivalence.Contravariant<Equivalence> map-1
+        (|>> :representation)
+        //encoding.Equivalence<U2>))
+
+  (def: #export format
+    (All [kind] (Format (Index kind)))
+    (binary.adapt (|>> :abstraction)
+                  (|>> :representation)
+                  //encoding.u2-format))
+  )