WIP: Make new-luxc instructions rely on the Descriptor type.

2 files changed, 109 insertions, 142 deletions

diff --git a/new-luxc/source/luxc/lang/host/jvm/def.lux b/new-luxc/source/luxc/lang/host/jvm/def.lux
index 138098929..9abf0db35 100644
--- a/new-luxc/source/luxc/lang/host/jvm/def.lux
+++ b/new-luxc/source/luxc/lang/host/jvm/def.lux
@@ -14,6 +14,9 @@
      ["." list ("#/." functor)]]]
    [target
     [jvm
+     ["." descriptor (#+ Descriptor)]
+     [encoding
+      ["." name]]
      ["$t" type (#+ Method Class Type Parameter)
       ["." reflection]]]]]
   ["." //])
@@ -74,38 +77,6 @@
                     (list.enumerate values))
       output)))
 
-(def: (exception-class-name type)
-  (-> Type Text)
-  (case type
-    (#$t.Primitive prim)
-    (case prim
-      #$t.Boolean reflection.boolean
-      #$t.Byte    reflection.byte
-      #$t.Short   reflection.short
-      #$t.Int     reflection.int
-      #$t.Long    reflection.long
-      #$t.Float   reflection.float
-      #$t.Double  reflection.double
-      #$t.Char    reflection.char)
-
-    (#$t.Array sub)
-    (format $t.array-prefix (exception-class-name sub))
-
-    (#$t.Generic generic)
-    (case generic
-      (#$t.Class class params)
-      ($t.binary-name class)
-
-      (^or (#$t.Var _) (#$t.Wildcard _))
-      ($t.binary-name $t.object-class))
-    ))
-
-(def: exceptions-array
-  (-> Method (Array Text))
-  (|>> (get@ #$t.exceptions)
-       (list/map (|>> #$t.Generic ..exception-class-name))
-       string-array))
-
 (def: (version-flag version)
   (-> //.Version Int)
   (case version
@@ -186,6 +157,8 @@
       ## (ClassWriter::COMPUTE_FRAMES)
       ))
 
+(def: binary-name (|>> name.internal name.read))
+
 (template [<name> <flag>]
   [(def: #export (<name> version visibility config name parameters super interfaces
                          definitions)
@@ -198,18 +171,18 @@
                                                 <flag>
                                                 (visibility-flag visibility)
                                                 (class-flags config))
-                                            ($t.binary-name name)
+                                            (..binary-name name)
                                             (parameters-signature parameters super interfaces)
-                                            (|> super product.left $t.binary-name)
+                                            (|> super product.left ..binary-name)
                                             (|> interfaces
-                                                (list/map (|>> product.left $t.binary-name))
+                                                (list/map (|>> product.left ..binary-name))
                                                 string-array)))
                       definitions)
            _ (ClassWriter::visitEnd writer)]
        (ClassWriter::toByteArray writer)))]
 
-  [class     +0]
-  [abstract  (Opcodes::ACC_ABSTRACT)]
+  [class    +0]
+  [abstract (Opcodes::ACC_ABSTRACT)]
   )
 
 (def: $Object Class ["java.lang.Object" (list)])
@@ -225,27 +198,27 @@
                                              (Opcodes::ACC_INTERFACE)
                                              (visibility-flag visibility)
                                              (class-flags config))
-                                         ($t.binary-name name)
+                                         (..binary-name name)
                                          (parameters-signature parameters $Object interfaces)
-                                         (|> $Object product.left $t.binary-name)
+                                         (|> $Object product.left ..binary-name)
                                          (|> interfaces
-                                             (list/map (|>> product.left $t.binary-name))
+                                             (list/map (|>> product.left ..binary-name))
                                              string-array)))
                    definitions)
         _ (ClassWriter::visitEnd writer)]
     (ClassWriter::toByteArray writer)))
 
 (def: #export (method visibility config name type then)
-  (-> //.Visibility //.Method-Config Text Method //.Inst
+  (-> //.Visibility //.Method-Config Text (Descriptor descriptor.Method) //.Inst
       //.Def)
   (function (_ writer)
     (let [=method (ClassWriter::visitMethod ($_ i.+
                                                 (visibility-flag visibility)
                                                 (method-flags config))
-                                            ($t.binary-name name)
-                                            ($t.method-descriptor type)
-                                            ($t.method-signature type)
-                                            (exceptions-array type)
+                                            (..binary-name name)
+                                            (descriptor.descriptor type)
+                                            (host.null)
+                                            (string-array (list))
                                             writer)
           _ (MethodVisitor::visitCode =method)
           _ (then =method)
@@ -254,30 +227,30 @@
       writer)))
 
 (def: #export (abstract-method visibility config name type)
-  (-> //.Visibility //.Method-Config Text Method
+  (-> //.Visibility //.Method-Config Text (Descriptor descriptor.Method)
       //.Def)
   (function (_ writer)
     (let [=method (ClassWriter::visitMethod ($_ i.+
                                                 (visibility-flag visibility)
                                                 (method-flags config)
                                                 (Opcodes::ACC_ABSTRACT))
-                                            ($t.binary-name name)
-                                            ($t.method-descriptor type)
-                                            ($t.method-signature type)
-                                            (exceptions-array type)
+                                            (..binary-name name)
+                                            (descriptor.descriptor type)
+                                            (host.null)
+                                            (string-array (list))
                                             writer)
           _ (MethodVisitor::visitEnd =method)]
       writer)))
 
 (def: #export (field visibility config name type)
-  (-> //.Visibility //.Field-Config Text Type //.Def)
+  (-> //.Visibility //.Field-Config Text (Descriptor descriptor.Field) //.Def)
   (function (_ writer)
     (let [=field (do-to (ClassWriter::visitField ($_ i.+
                                                      (visibility-flag visibility)
                                                      (field-flags config))
-                                                 ($t.binary-name name)
-                                                 ($t.descriptor type)
-                                                 ($t.signature type)
+                                                 (..binary-name name)
+                                                 (descriptor.descriptor type)
+                                                 (host.null)
                                                  (host.null)
                                                  writer)
                    (FieldVisitor::visitEnd))]
@@ -290,23 +263,23 @@
        (let [=field (do-to (ClassWriter::visitField ($_ i.+
                                                         (visibility-flag visibility)
                                                         (field-flags config))
-                                                    ($t.binary-name name)
-                                                    ($t.descriptor <jvm-type>)
-                                                    ($t.signature <jvm-type>)
+                                                    (..binary-name name)
+                                                    (descriptor.descriptor <jvm-type>)
+                                                    (host.null)
                                                     (<prepare> value)
                                                     writer)
                       (FieldVisitor::visitEnd))]
          writer)))]
 
-  [boolean-field Bit  $t.boolean function.identity]
-  [byte-field    Int  $t.byte    host.long-to-byte]
-  [short-field   Int  $t.short   host.long-to-short]
-  [int-field     Int  $t.int     host.long-to-int]
-  [long-field    Int  $t.long    function.identity]
-  [float-field   Frac $t.float   host.double-to-float]
-  [double-field  Frac $t.double  function.identity]
-  [char-field    Nat  $t.char    (|>> .int host.long-to-int host.int-to-char)]
-  [string-field  Text ($t.class "java.lang.String" (list)) function.identity]
+  [boolean-field Bit  descriptor.boolean                    function.identity]
+  [byte-field    Int  descriptor.byte                       host.long-to-byte]
+  [short-field   Int  descriptor.short                      host.long-to-short]
+  [int-field     Int  descriptor.int                        host.long-to-int]
+  [long-field    Int  descriptor.long                       function.identity]
+  [float-field   Frac descriptor.float                      host.double-to-float]
+  [double-field  Frac descriptor.double                     function.identity]
+  [char-field    Nat  descriptor.char                       (|>> .int host.long-to-int host.int-to-char)]
+  [string-field  Text (descriptor.class "java.lang.String") function.identity]
   )
 
 (def: #export (fuse defs)
diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux
index fcf28d4a7..a54367a72 100644
--- a/new-luxc/source/luxc/lang/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux
@@ -1,16 +1,16 @@
 (.module:
-  [lux (#- Type int char)
+  [lux (#- int char)
    ["." host (#+ import: do-to)]
    [abstract
     [monad (#+ do)]]
    [control
     ["." function]
+    ["." try]
     ["p" parser
      ["s" code]]]
    [data
     ["." product]
     ["." maybe]
-    ["." error]
     [number
      ["n" nat]
      ["i" int]]
@@ -22,7 +22,11 @@
     [syntax (#+ syntax:)]]
    [target
     [jvm
-     ["." type (#+ Primitive Method Type)]]]
+     ["." descriptor (#+ Descriptor Primitive) ("#@." equivalence)]
+     [encoding
+      ["." name]]
+     [type
+      ["." box]]]]
    [tool
     [compiler
      [phase (#+ Operation)]]]]
@@ -131,7 +135,7 @@
 (def: #export make-label
   (All [s] (Operation s org/objectweb/asm/Label))
   (function (_ state)
-    (#error.Success [state (org/objectweb/asm/Label::new)])))
+    (#try.Success [state (org/objectweb/asm/Label::new)])))
 
 (def: #export (with-label action)
   (All [a] (-> (-> org/objectweb/asm/Label a) a))
@@ -235,10 +239,10 @@
 
 (template [<name> <inst>]
   [(def: #export (<name> class field type)
-     (-> Text Text Type Inst)
+     (-> (Descriptor descriptor.Class) Text (Descriptor descriptor.Field) Inst)
      (function (_ visitor)
        (do-to visitor
-         (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (type.binary-name class) field (type.descriptor type)))))]
+         (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (descriptor.class-name class) field (descriptor.descriptor type)))))]
 
   [GETSTATIC org/objectweb/asm/Opcodes::GETSTATIC]
   [PUTSTATIC org/objectweb/asm/Opcodes::PUTSTATIC]
@@ -249,10 +253,10 @@
 
 (template [<name> <inst>]
   [(def: #export (<name> class)
-     (-> Text Inst)
+     (-> (Descriptor descriptor.Object) Inst)
      (function (_ visitor)
        (do-to visitor
-         (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (type.binary-name class)))))]
+         (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (descriptor.class-name class)))))]
 
   [CHECKCAST  org/objectweb/asm/Opcodes::CHECKCAST]
   [NEW        org/objectweb/asm/Opcodes::NEW]
@@ -261,26 +265,30 @@
   )
 
 (def: #export (NEWARRAY type)
-  (-> Primitive Inst)
+  (-> (Descriptor Primitive) Inst)
   (function (_ visitor)
     (do-to visitor
       (org/objectweb/asm/MethodVisitor::visitIntInsn (org/objectweb/asm/Opcodes::NEWARRAY)
-                                                     (case type
-                                                       #type.Boolean (org/objectweb/asm/Opcodes::T_BOOLEAN)
-                                                       #type.Byte    (org/objectweb/asm/Opcodes::T_BYTE)
-                                                       #type.Short   (org/objectweb/asm/Opcodes::T_SHORT)
-                                                       #type.Int     (org/objectweb/asm/Opcodes::T_INT)
-                                                       #type.Long    (org/objectweb/asm/Opcodes::T_LONG)
-                                                       #type.Float   (org/objectweb/asm/Opcodes::T_FLOAT)
-                                                       #type.Double  (org/objectweb/asm/Opcodes::T_DOUBLE)
-                                                       #type.Char    (org/objectweb/asm/Opcodes::T_CHAR))))))
+                                                     (`` (cond (~~ (template [<descriptor> <opcode>]
+                                                                     [(descriptor@= <descriptor> type) (<opcode>)]
+                                                                     
+                                                                     [descriptor.boolean org/objectweb/asm/Opcodes::T_BOOLEAN]
+                                                                     [descriptor.byte    org/objectweb/asm/Opcodes::T_BYTE]
+                                                                     [descriptor.short   org/objectweb/asm/Opcodes::T_SHORT]
+                                                                     [descriptor.int     org/objectweb/asm/Opcodes::T_INT]
+                                                                     [descriptor.long    org/objectweb/asm/Opcodes::T_LONG]
+                                                                     [descriptor.float   org/objectweb/asm/Opcodes::T_FLOAT]
+                                                                     [descriptor.double  org/objectweb/asm/Opcodes::T_DOUBLE]
+                                                                     [descriptor.char    org/objectweb/asm/Opcodes::T_CHAR]))
+                                                               ## else
+                                                               (undefined)))))))
 
 (template [<name> <inst>]
-  [(def: #export (<name> class method-name method-signature interface?)
-     (-> Text Text Method Bit Inst)
+  [(def: #export (<name> class method-name type interface?)
+     (-> (Descriptor descriptor.Class) Text (Descriptor descriptor.Method) Bit Inst)
      (function (_ visitor)
        (do-to visitor
-         (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>) (type.binary-name class) method-name (type.method-descriptor method-signature) interface?))))]
+         (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>) (descriptor.class-name class) method-name (descriptor.descriptor type) interface?))))]
 
   [INVOKESTATIC    org/objectweb/asm/Opcodes::INVOKESTATIC]
   [INVOKEVIRTUAL   org/objectweb/asm/Opcodes::INVOKEVIRTUAL]
@@ -338,10 +346,10 @@
         (org/objectweb/asm/MethodVisitor::visitTableSwitchInsn min max default labels-array)))))
 
 (def: #export (try @from @to @handler exception)
-  (-> //.Label //.Label //.Label Text Inst)
+  (-> //.Label //.Label //.Label (Descriptor descriptor.Class) Inst)
   (function (_ visitor)
     (do-to visitor
-      (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (type.binary-name exception)))))
+      (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (descriptor.class-name exception)))))
 
 (def: #export (label @label)
   (-> //.Label Inst)
@@ -350,63 +358,49 @@
       (org/objectweb/asm/MethodVisitor::visitLabel @label))))
 
 (def: #export (array type)
-  (-> Type Inst)
-  (case type
-    (#type.Primitive prim)
-    (NEWARRAY prim)
-
-    (#type.Generic generic)
-    (let [elem-class (case generic
-                       (#type.Class class params)
-                       (type.binary-name class)
-
-                       _
-                       (type.binary-name "java.lang.Object"))]
-      (ANEWARRAY elem-class))
-
-    _
-    (ANEWARRAY (type.descriptor type))))
-
-(def: (primitive-wrapper type)
-  (-> Primitive Text)
-  (case type
-    #type.Boolean "java.lang.Boolean"
-    #type.Byte    "java.lang.Byte"
-    #type.Short   "java.lang.Short"
-    #type.Int     "java.lang.Integer"
-    #type.Long    "java.lang.Long"
-    #type.Float   "java.lang.Float"
-    #type.Double  "java.lang.Double"
-    #type.Char    "java.lang.Character"))
-
-(def: (primitive-unwrap type)
-  (-> Primitive Text)
-  (case type
-    #type.Boolean "booleanValue"
-    #type.Byte    "byteValue"
-    #type.Short   "shortValue"
-    #type.Int     "intValue"
-    #type.Long    "longValue"
-    #type.Float   "floatValue"
-    #type.Double  "doubleValue"
-    #type.Char    "charValue"))
+  (-> (Descriptor descriptor.Value) Inst)
+  (case (descriptor.primitive? type)
+    (#.Left object)
+    (ANEWARRAY object)
+
+    (#.Right primitive)
+    (NEWARRAY primitive)))
+
+(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>]
+  [(def: (<name> type)
+     (-> (Descriptor Primitive) Text)
+     (`` (cond (~~ (template [<descriptor> <output>]
+                     [(descriptor@= <descriptor> type) <output>]
+                     
+                     [descriptor.boolean <boolean>]
+                     [descriptor.byte    <byte>]
+                     [descriptor.short   <short>]
+                     [descriptor.int     <int>]
+                     [descriptor.long    <long>]
+                     [descriptor.float   <float>]
+                     [descriptor.double  <double>]
+                     [descriptor.char    <char>]))
+               ## else
+               (undefined))))]
+
+  [primitive-wrapper
+   box.boolean box.byte box.short box.int
+   box.long box.float box.double box.char]
+  [primitive-unwrap
+   "booleanValue" "byteValue" "shortValue" "intValue"
+   "longValue" "floatValue" "doubleValue" "charValue"]
+  )
 
 (def: #export (wrap type)
-  (-> Primitive Inst)
-  (let [class (primitive-wrapper type)]
-    (|>> (INVOKESTATIC class "valueOf"
-                       (type.method (list (#type.Primitive type))
-                                    (#.Some (type.class class (list)))
-                                    (list))
-                       #0))))
+  (-> (Descriptor Primitive) Inst)
+  (let [wrapper (descriptor.class (primitive-wrapper type))]
+    (INVOKESTATIC wrapper "valueOf" (descriptor.method [(list type) wrapper]) #0)))
 
 (def: #export (unwrap type)
-  (-> Primitive Inst)
-  (let [class (primitive-wrapper type)]
-    (|>> (CHECKCAST class)
-         (INVOKEVIRTUAL class (primitive-unwrap type)
-                        (type.method (list) (#.Some (#type.Primitive type)) (list))
-                        #0))))
+  (-> (Descriptor Primitive) Inst)
+  (let [wrapper (descriptor.class (primitive-wrapper type))]
+    (|>> (CHECKCAST wrapper)
+         (INVOKEVIRTUAL wrapper (primitive-unwrap type) (descriptor.method [(list) type]) #0))))
 
 (def: #export (fuse insts)
   (-> (List Inst) Inst)