Yet more fiddling with types for JVM interop.

+ Some progress on anonymous classes.
+ More elaborate handling of JVM arrays.

2 files changed, 166 insertions, 158 deletions

diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.lux b/new-luxc/source/luxc/lang/translation/jvm/function.lux
index ae876c3fc..d0764796f 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/function.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/function.lux
@@ -9,13 +9,13 @@
     ["." text
      format]
     [collection
-     ["." list ("#/." functor monoid)]]]
+     ["." list ("#@." functor monoid)]]]
    [target
-    [jvm
-     ["." type (#+ Type Method)]]]
+    ["." jvm #_
+     ["#" type (#+ Type Method)]]]
    [tool
     [compiler
-     [analysis (#+ Arity)]
+     [analysis (#+ Arity Environment)]
      [synthesis (#+ Synthesis Abstraction Apply)]
      ["_." reference (#+ Register Variable)]
      ["." phase
@@ -30,9 +30,8 @@
    ["." runtime]
    ["." reference]])
 
-
 (def: arity-field Text "arity")
-(def: $Object Type (type.class "java.lang.Object" (list)))
+(def: $Object Type (jvm.class "java.lang.Object" (list)))
 
 (def: (poly-arg? arity)
   (-> Arity Bit)
@@ -40,29 +39,29 @@
 
 (def: (reset-method class)
   (-> Text Method)
-  (type.method (list) (#.Some (type.class class (list))) (list)))
+  (jvm.method (list) (#.Some (jvm.class class (list))) (list)))
 
 (def: (captured-args env)
-  (-> (List Variable) (List Type))
+  (-> Environment (List Type))
   (list.repeat (list.size env) $Object))
 
 (def: (init-method env arity)
-  (-> (List Variable) Arity Method)
+  (-> Environment Arity Method)
   (if (poly-arg? arity)
-    (type.method (list.concat (list (captured-args env)
-                                    (list type.int)
-                                    (list.repeat (dec arity) $Object)))
-                 #.None
-                 (list))
-    (type.method (captured-args env) #.None (list))))
+    (jvm.method (list.concat (list (captured-args env)
+                                   (list jvm.int)
+                                   (list.repeat (dec arity) $Object)))
+                #.None
+                (list))
+    (jvm.method (captured-args env) #.None (list))))
 
 (def: (implementation-method arity)
-  (type.method (list.repeat arity $Object) (#.Some $Object) (list)))
+  (jvm.method (list.repeat arity $Object) (#.Some $Object) (list)))
 
 (def: get-amount-of-partialsI
   Inst
   (|>> (_.ALOAD 0)
-       (_.GETFIELD //.function-class runtime.partials-field type.int)))
+       (_.GETFIELD //.function-class runtime.partials-field jvm.int)))
 
 (def: (load-fieldI class field)
   (-> Text Text Inst)
@@ -72,7 +71,7 @@
 (def: (inputsI start amount)
   (-> Register Nat Inst)
   (|> (list.n/range start (n/+ start (dec amount)))
-      (list/map _.ALOAD)
+      (list@map _.ALOAD)
       _.fuse))
 
 (def: (applysI start amount)
@@ -97,24 +96,24 @@
       (list.repeat amount)
       _.fuse))
 
-(def: (with-captured env)
-  (-> (List Variable) Def)
-  (|> (list.enumerate env)
-      (list/map (.function (_ [env-idx env-source])
-                  (def.field #$.Private $.finalF (reference.foreign-name env-idx) $Object)))
-      def.fuse))
+(def: #export with-environment
+  (-> Environment Def)
+  (|>> list.enumerate
+       (list@map (.function (_ [env-idx env-source])
+                   (def.field #$.Private $.finalF (reference.foreign-name env-idx) $Object)))
+       def.fuse))
 
 (def: (with-partial arity)
   (-> Arity Def)
   (if (poly-arg? arity)
     (|> (list.n/range 0 (n/- 2 arity))
-        (list/map (.function (_ idx)
+        (list@map (.function (_ idx)
                     (def.field #$.Private $.finalF (reference.partial-name idx) $Object)))
         def.fuse)
     function.identity))
 
 (def: (instance class arity env)
-  (-> Text Arity (List Variable) (Operation Inst))
+  (-> Text Arity Environment (Operation Inst))
   (do phase.monad
     [captureI+ (monad.map @ reference.variable env)
      #let [argsI (if (poly-arg? arity)
@@ -129,14 +128,14 @@
                (_.INVOKESPECIAL class "<init>" (init-method env arity) #0)))))
 
 (def: (with-reset class arity env)
-  (-> Text Arity (List Variable) Def)
+  (-> Text Arity Environment Def)
   (def.method #$.Public $.noneM "reset" (reset-method class)
               (if (poly-arg? arity)
                 (let [env-size (list.size env)
                       captureI (|> (case env-size
                                      0 (list)
                                      _ (list.n/range 0 (dec env-size)))
-                                   (list/map (.function (_ source)
+                                   (list@map (.function (_ source)
                                                (|>> (_.ALOAD 0)
                                                     (_.GETFIELD class (reference.foreign-name source) $Object))))
                                    _.fuse)
@@ -161,7 +160,7 @@
 
 (def: function-init-method
   Method
-  (type.method (list type.int) #.None (list)))
+  (jvm.method (list jvm.int) #.None (list)))
 
 (def: (function-init arity env-size)
   (-> Arity Nat Inst)
@@ -172,21 +171,21 @@
          (_.INVOKESPECIAL //.function-class "<init>" function-init-method #0))))
 
 (def: (with-init class env arity)
-  (-> Text (List Variable) Arity Def)
+  (-> Text Environment Arity Def)
   (let [env-size (list.size env)
         offset-partial (: (-> Nat Nat)
                           (|>> inc (n/+ env-size)))
         store-capturedI (|> (case env-size
                               0 (list)
                               _ (list.n/range 0 (dec env-size)))
-                            (list/map (.function (_ register)
+                            (list@map (.function (_ register)
                                         (|>> (_.ALOAD 0)
                                              (_.ALOAD (inc register))
                                              (_.PUTFIELD class (reference.foreign-name register) $Object))))
                             _.fuse)
         store-partialI (if (poly-arg? arity)
                          (|> (list.n/range 0 (n/- 2 arity))
-                             (list/map (.function (_ idx)
+                             (list@map (.function (_ idx)
                                          (let [register (offset-partial idx)]
                                            (|>> (_.ALOAD 0)
                                                 (_.ALOAD (inc register))
@@ -201,18 +200,18 @@
                      _.RETURN))))
 
 (def: (with-apply class env function-arity @begin bodyI apply-arity)
-  (-> Text (List Variable) Arity Label Inst Arity
+  (-> Text Environment Arity Label Inst Arity
       Def)
   (let [num-partials (dec function-arity)
         @default ($.new-label [])
-        @labels (list/map $.new-label (list.repeat num-partials []))
+        @labels (list@map $.new-label (list.repeat num-partials []))
         arity-over-extent (|> (.int function-arity) (i/- (.int apply-arity)))
-        casesI (|> (list/compose @labels (list @default))
+        casesI (|> (list@compose @labels (list @default))
                    (list.zip2 (list.n/range 0 num-partials))
-                   (list/map (.function (_ [stage @label])
+                   (list@map (.function (_ [stage @label])
                                (let [load-partialsI (if (n/> 0 stage)
                                                       (|> (list.n/range 0 (dec stage))
-                                                          (list/map (|>> reference.partial-name (load-fieldI class)))
+                                                          (list@map (|>> reference.partial-name (load-fieldI class)))
                                                           _.fuse)
                                                       function.identity)]
                                  (cond (i/= arity-over-extent (.int stage))
@@ -242,7 +241,7 @@
                                              load-capturedI (|> (case env-size
                                                                   0 (list)
                                                                   _ (list.n/range 0 (dec env-size)))
-                                                                (list/map (|>> reference.foreign-name (load-fieldI class)))
+                                                                (list@map (|>> reference.foreign-name (load-fieldI class)))
                                                                 _.fuse)]
                                          (|>> (_.label @label)
                                               (_.NEW class)
@@ -262,20 +261,20 @@
                      (_.TABLESWITCH +0 (|> num-partials dec .int)
                                     @default @labels)
                      casesI
-                     (_.INVOKESTATIC //.runtime-class "apply_fail" (type.method (list) #.None (list)) #0)
+                     (_.INVOKESTATIC //.runtime-class "apply_fail" (jvm.method (list) #.None (list)) #0)
                      _.NULL
                      _.ARETURN
                      ))))
 
 (def: #export (with-function @begin class env arity bodyI)
-  (-> Label Text (List Variable) Arity Inst
+  (-> Label Text Environment Arity Inst
       (Operation [Def Inst]))
   (let [env-size (list.size env)
         applyD (: Def
                   (if (poly-arg? arity)
                     (|> (n/min arity runtime.num-apply-variants)
                         (list.n/range 1)
-                        (list/map (with-apply class env arity @begin bodyI))
+                        (list@map (with-apply class env arity @begin bodyI))
                         (list& (with-implementation arity @begin bodyI))
                         def.fuse)
                     (def.method #$.Public $.strictM runtime.apply-method (runtime.apply-signature 1)
@@ -284,7 +283,7 @@
                                      _.ARETURN))))
         functionD (: Def
                      (|>> (def.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (.int arity))
-                          (with-captured env)
+                          (with-environment env)
                           (with-partial arity)
                           (with-init class env arity)
                           (with-reset class arity env)
@@ -323,7 +322,7 @@
     [functionI (translate functionS)
      argsI (monad.map @ translate argsS)
      #let [applyI (|> (segment runtime.num-apply-variants argsI)
-                      (list/map (.function (_ chunkI+)
+                      (list@map (.function (_ chunkI+)
                                   (|>> (_.CHECKCAST //.function-class)
                                        (_.fuse chunkI+)
                                        (_.INVOKEVIRTUAL //.function-class runtime.apply-method (runtime.apply-signature (list.size chunkI+)) #0))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
index 55798c806..be2a0bace 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -31,6 +31,8 @@
       ["." generation
        [extension (#+ Nullary Unary Binary
                       nullary unary binary)]]
+      [analysis
+       [".A" reference]]
       ["." extension
        ["." bundle]
        [analysis
@@ -39,17 +41,27 @@
   [luxc
    [lang
     [host
-     ["$" jvm (#+ Label Inst Handler Bundle Operation Phase)
+     ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase)
       ["_" inst]
-      ["_." def]]]]])
+      ["_." def]]]]]
+  ["." /// #_
+   ["#." reference]
+   ["#." function]])
 
-(template [<name>]
-  [(exception: #export (<name> {message Text})
-     message)]
+(exception: #export invalid-syntax-for-argument-generation)
 
-  [invalid-syntax-for-jvm-type]
-  [invalid-syntax-for-argument-generation]
-  )
+(def: (custom [parser handler])
+  (All [s]
+    (-> [(<s>.Parser s)
+         (-> Text Phase s (Operation Inst))]
+        Handler))
+  (function (_ extension-name phase input)
+    (case (<s>.run input parser)
+      (#error.Success input')
+      (handler extension-name phase input')
+
+      (#error.Failure error)
+      (phase.throw extension.invalid-syntax [extension-name %synthesis input]))))
 
 (template [<name> <inst>]
   [(def: <name>
@@ -306,7 +318,17 @@
                "char" jvm.char
                _ (jvm.class elem-class (list)))))
 
-(def: (array::length extension-name generate inputs)
+(def: (primitive-array-length-handler jvm-primitive)
+  (-> Type Handler)
+  (..custom [<s>.any
+             (function (_ extension-name generate arrayS)
+               (do phase.monad
+                 [arrayI (generate arrayS)]
+                 (wrap (|>> arrayI
+                            (_.CHECKCAST (jvm.descriptor (jvm.array 1 jvm-primitive)))
+                            _.ARRAYLENGTH))))]))
+
+(def: (array::length::object extension-name generate inputs)
   Handler
   (case inputs
     (^ (list (synthesis.i64 nesting)
@@ -427,7 +449,17 @@
   Bundle
   (<| (bundle.prefix "array")
       (|> bundle.empty
-          (bundle.install "length" array::length)
+          (dictionary.merge (<| (bundle.prefix "length")
+                                (|> bundle.empty
+                                    (bundle.install "boolean" (primitive-array-length-handler jvm.boolean))
+                                    (bundle.install "byte" (primitive-array-length-handler jvm.byte))
+                                    (bundle.install "short" (primitive-array-length-handler jvm.short))
+                                    (bundle.install "int" (primitive-array-length-handler jvm.int))
+                                    (bundle.install "long" (primitive-array-length-handler jvm.long))
+                                    (bundle.install "float" (primitive-array-length-handler jvm.float))
+                                    (bundle.install "double" (primitive-array-length-handler jvm.double))
+                                    (bundle.install "char" (primitive-array-length-handler jvm.char))
+                                    (bundle.install "object" array::length::object))))
           (dictionary.merge (<| (bundle.prefix "new")
                                 (|> bundle.empty
                                     (bundle.install "boolean" (new-primitive-array-handler jvm.boolean))
@@ -671,62 +703,30 @@
     _
     (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
 
-(def: base-type
-  (<t>.Parser Type)
-  ($_ <>.either
-      (<>.after (<t>.this "boolean") (<>@wrap jvm.boolean))
-      (<>.after (<t>.this "byte") (<>@wrap jvm.byte))
-      (<>.after (<t>.this "short") (<>@wrap jvm.short))
-      (<>.after (<t>.this "int") (<>@wrap jvm.int))
-      (<>.after (<t>.this "long") (<>@wrap jvm.long))
-      (<>.after (<t>.this "float") (<>@wrap jvm.float))
-      (<>.after (<t>.this "double") (<>@wrap jvm.double))
-      (<>.after (<t>.this "char") (<>@wrap jvm.char))
-      (<>@map (function (_ name)
-                (jvm.class name (list)))
-              (<t>.many (<t>.none-of "[")))
-      ))
-
-(def: java-type
-  (<t>.Parser Type)
-  (do <>.monad
-    [raw base-type
-     nesting (<>.some (<t>.this "[]"))]
-    (wrap (jvm.array (list.size nesting) raw))))
-
-(def: (generate-type argD)
-  (-> Text (Operation Type))
-  (case (<t>.run java-type argD)
-    (#error.Failure error)
-    (phase.throw invalid-syntax-for-jvm-type argD)
-
-    (#error.Success type)
-    (phase@wrap type)))
-
 (def: (generate-arg generate argS)
   (-> (-> Synthesis (Operation Inst)) Synthesis
       (Operation [Type Inst]))
   (case argS
     (^ (synthesis.tuple (list (synthesis.text argD) argS)))
     (do phase.monad
-      [argD (phase.lift (:: error.monad map
-                            jvm.reflection-class
-                            (jvm.parse-signature argD)))
-       argT (generate-type argD)
+      [argT (phase.lift (<t>.run jvm.parse-signature argD))
        argI (generate argS)]
       (wrap [argT argI]))
 
     _
-    (phase.throw invalid-syntax-for-argument-generation "")))
+    (phase.throw invalid-syntax-for-argument-generation [])))
 
 (def: (method-return-type description)
   (-> Text (Operation (Maybe Type)))
   (case description
-    "void"
+    (^ (static jvm.void-descriptor))
     (phase@wrap #.None)
 
     _
-    (phase@map (|>> #.Some) (generate-type description))))
+    (|> description
+        (<t>.run jvm.parse-signature)
+        phase.lift
+        (phase@map (|>> #.Some)))))
 
 (def: (prepare-argI [type argI])
   (-> [Type Inst] Inst)
@@ -738,46 +738,35 @@
     #.None
     argI))
 
-(def: (invoke::static extension-name generate inputs)
+(def: invoke::static
   Handler
-  (case inputs
-    (^ (list& (synthesis.text class)
-              (synthesis.text method)
-              (synthesis.text unboxed)
-              argsS))
-    (do phase.monad
-      [argsTI (monad.map @ (generate-arg generate) argsS)
-       returnT (method-return-type unboxed)]
-      (wrap (|>> (_.fuse (list@map ..prepare-argI argsTI))
-                 (_.INVOKESTATIC class method
-                                 (jvm.method (list@map product.left argsTI) returnT (list))
-                                 false))))
-
-    _
-    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+  (..custom
+   [($_ <>.and <s>.text <s>.text <s>.text (<>.some <s>.any))
+    (function (_ extension-name generate [class method unboxed argsS])
+      (do phase.monad
+        [argsTI (monad.map @ (generate-arg generate) argsS)
+         returnT (method-return-type unboxed)]
+        (wrap (|>> (_.fuse (list@map ..prepare-argI argsTI))
+                   (_.INVOKESTATIC class method
+                                   (jvm.method (list@map product.left argsTI) returnT (list))
+                                   false)))))]))
 
 (template [<name> <invoke> <interface?>]
-  [(def: (<name> extension-name generate inputs)
+  [(def: <name>
      Handler
-     (case inputs
-       (^ (list& (synthesis.text class)
-                 (synthesis.text method)
-                 (synthesis.text unboxed)
-                 objectS
-                 argsS))
-       (do phase.monad
-         [objectI (generate objectS)
-          argsTI (monad.map @ (generate-arg generate) argsS)
-          returnT (method-return-type unboxed)]
-         (wrap (|>> objectI
-                    (_.CHECKCAST class)
-                    (_.fuse (list@map ..prepare-argI argsTI))
-                    (<invoke> class method
-                              (jvm.method (list@map product.left argsTI) returnT (list))
-                              <interface?>))))
-
-       _
-       (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))]
+     (..custom
+      [($_ <>.and <s>.text <s>.text <s>.text <s>.any (<>.some <s>.any))
+       (function (_ extension-name generate [class method unboxed objectS argsS])
+         (do phase.monad
+           [objectI (generate objectS)
+            argsTI (monad.map @ (generate-arg generate) argsS)
+            returnT (method-return-type unboxed)]
+           (wrap (|>> objectI
+                      (_.CHECKCAST class)
+                      (_.fuse (list@map ..prepare-argI argsTI))
+                      (<invoke> class method
+                                (jvm.method (list@map product.left argsTI) returnT (list))
+                                <interface?>)))))]))]
 
   [invoke::virtual _.INVOKEVIRTUAL false]
   [invoke::special _.INVOKESPECIAL false]
@@ -821,19 +810,6 @@
                                     (bundle.install "constructor" invoke::constructor))))
           )))
 
-(def: (custom [parser handler])
-  (All [s]
-    (-> [(<s>.Parser s)
-         (-> Text Phase s (Operation Inst))]
-        Handler))
-  (function (_ extension-name phase input)
-    (case (<s>.run input parser)
-      (#error.Success input')
-      (handler extension-name phase input')
-
-      (#error.Failure error)
-      (phase.throw extension.invalid-syntax [extension-name %synthesis input]))))
-
 (def: var
   (<s>.Parser Var)
   <s>.text)
@@ -902,7 +878,7 @@
 
 (def: return
   (<s>.Parser Return)
-  (<>.or (<s>.constant! ["" "void"])
+  (<>.or (<s>.constant! ["" jvm.void-descriptor])
          ..jvm-type))
 
 (def: overriden-method-definition
@@ -998,6 +974,39 @@
       (#synthesis.Extension [name inputsS+])
       (#synthesis.Extension [name (list@map recur inputsS+)]))))
 
+(def: $Object (jvm.class jvm.object-class (list)))
+
+(def: (anonymous-init-method env)
+  (-> Environment Method)
+  (jvm.method (list.repeat (list.size env) $Object)
+              #.None
+              (list)))
+
+(def: (with-anonymous-init class env)
+  (-> Text Environment Def)
+  (let [store-capturedI (|> env
+                            list.size
+                            list.indices
+                            (list@map (.function (_ register)
+                                        (|>> (_.ALOAD 0)
+                                             (_.ALOAD (inc register))
+                                             (_.PUTFIELD class (///reference.foreign-name register) $Object))))
+                            _.fuse)]
+    (_def.method #$.Public $.noneM "<init>" (anonymous-init-method env)
+                 (|>> (_.ALOAD 0)
+                      (_.INVOKESPECIAL jvm.object-class "<init>" (jvm.method (list) #.None (list)) #0)
+                      store-capturedI
+                      _.RETURN))))
+
+(def: (anonymous-instance class env)
+  (-> Text Environment (Operation Inst))
+  (do phase.monad
+    [captureI+ (monad.map @ ///reference.variable env)]
+    (wrap (|>> (_.NEW class)
+               _.DUP
+               (_.fuse captureI+)
+               (_.INVOKESPECIAL class "<init>" (anonymous-init-method env) #0)))))
+
 (def: class::anonymous
   Handler
   (..custom
@@ -1012,14 +1021,15 @@
                                           constructor-args
                                           overriden-methods])
       (do phase.monad
-        [#let [global-mapping (|> overriden-methods
-                                  ## Get all the environments.
-                                  (list@map product.left)
-                                  ## Combine them.
-                                  list@join
-                                  ## Remove duplicates.
-                                  (set.from-list reference.hash)
-                                  set.to-list
+        [#let [total-environment (|> overriden-methods
+                                     ## Get all the environments.
+                                     (list@map product.left)
+                                     ## Combine them.
+                                     list@join
+                                     ## Remove duplicates.
+                                     (set.from-list reference.hash)
+                                     set.to-list)
+               global-mapping (|> total-environment
                                   ## Give them names as "foreign" variables.
                                   list.enumerate
                                   (list@map (function (_ [id capture])
@@ -1043,14 +1053,13 @@
                                                  self-name arguments returnT exceptionsT
                                                  (normalize-method-body local-mapping body)]))
                                             overriden-methods)]
-         ## _ (generation.save! true ["" function-class]
-         ##                     [function-class
-         ##                      (def.class #$.V1_6 #$.Public $.finalC
-         ##                                 function-class (list)
-         ##                                 ($.simple-class //.function-class) (list)
-         ##                                 functionD)])
-         _ (phase.throw extension.invalid-syntax ["YOLO-TRON" %synthesis (list)])]
-        (wrap _.DUP)))]))
+         _ (generation.save! true ["" class-name]
+                             [class-name
+                              (_def.class #$.V1_6 #$.Public $.finalC
+                                          class-name (list)
+                                          super-class super-interfaces
+                                          (|>> (///function.with-environment total-environment)))])]
+        (anonymous-instance class-name total-environment)))]))
 
 (def: bundle::class
   Bundle