Made sure the "phase" parameter of extensions is always usable (even across language boundaries)

4 files changed, 223 insertions, 70 deletions

diff --git a/lux-jvm/source/luxc/lang/directive/jvm.lux b/lux-jvm/source/luxc/lang/directive/jvm.lux
index 4d5d88548..7b3235c06 100644
--- a/lux-jvm/source/luxc/lang/directive/jvm.lux
+++ b/lux-jvm/source/luxc/lang/directive/jvm.lux
@@ -369,7 +369,7 @@
     (#/.Return instruction) (..return instruction)))
 
 (def: (instruction instruction)
-  (-> (/.Instruction org/objectweb/asm/Label) Inst)
+  (-> (/.Instruction Inst org/objectweb/asm/Label) Inst)
   (case instruction
     #/.NOP _.NOP
     (#/.Constant instruction) (..constant instruction)
@@ -381,7 +381,8 @@
     (#/.Local instruction) (..local instruction)
     (#/.Stack instruction) (..stack instruction)
     (#/.Comparison instruction) (..comparison instruction)
-    (#/.Control instruction) (..control instruction)))
+    (#/.Control instruction) (..control instruction)
+    (#/.Embedded embedded) embedded))
 
 (type: Mapping
   (Dictionary /.Label org/objectweb/asm/Label))
@@ -460,9 +461,13 @@
     ))
 
 (def: (relabel_instruction [mapping instruction])
-  (Re_labeler /.Instruction)
+  (Re_labeler (/.Instruction Inst))
   (case instruction
-    #/.NOP [mapping #/.NOP]
+    (#/.Embedded embedded)
+    [mapping (#/.Embedded embedded)]
+
+    #/.NOP
+    [mapping #/.NOP]
 
     (^template [<tag>]
       [(<tag> instruction)
@@ -482,10 +487,10 @@
       [mapping (#/.Control instruction)])))
 
 (def: (relabel_bytecode [mapping bytecode])
-  (Re_labeler /.Bytecode)
+  (Re_labeler (/.Bytecode Inst))
   (row@fold (function (_ input [mapping output])
-              (let [[mapping input] (..relabel_instruction [mapping input])]
-                [mapping (row.add input output)]))
+              (let [[mapping input'] (..relabel_instruction [mapping input])]
+                [mapping (row.add input' output)]))
             [mapping (row.row)]
             bytecode))
 
@@ -494,7 +499,7 @@
   (dictionary.new nat.hash))
 
 (def: bytecode
-  (-> (/.Bytecode /.Label) jvm.Inst)
+  (-> (/.Bytecode Inst /.Label) jvm.Inst)
   (|>> [..fresh]
        ..relabel_bytecode
        product.right
@@ -502,15 +507,28 @@
        row.to_list
        _.fuse))
 
-(type: Handler
-  (generation.Handler jvm.Anchor (/.Bytecode /.Label) jvm.Definition))
+(with_expansions [<anchor> (as_is jvm.Anchor)
+                  <expression> (as_is Inst)
+                  <directive> (as_is jvm.Definition)
+                  <type_vars> (as_is <anchor> <expression> <directive>)]
+  (type: Handler
+    ## (generation.Handler jvm.Anchor (/.Bytecode Inst /.Label) jvm.Definition)
+    (-> extension.Name
+        (phase.Phase [(extension.Bundle <type_vars>)
+                      (generation.State <type_vars>)]
+                     Synthesis
+                     <expression>)
+        (phase.Phase [(extension.Bundle <type_vars>)
+                      (generation.State <type_vars>)]
+                     (List Synthesis)
+                     (/.Bytecode Inst /.Label)))))
 
 (def: (true_handler extender pseudo)
   (-> jvm.Extender Any jvm.Handler)
   (function (_ extension_name phase archive inputs)
     (do phase.monad
       [bytecode ((extender pseudo) extension_name phase archive inputs)]
-      (wrap (..bytecode (:coerce (/.Bytecode /.Label) bytecode))))))
+      (wrap (..bytecode (:coerce (/.Bytecode Inst /.Label) bytecode))))))
 
 (def: (def::generation extender)
   (-> jvm.Extender
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
index dc579c970..96fa95363 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
@@ -7,8 +7,8 @@
     ["." exception (#+ exception:)]
     ["." function]
     ["<>" parser ("#@." monad)
-     ["<t>" text]
-     ["<s>" synthesis (#+ Parser)]]]
+     ["<.>" text]
+     ["<.>" synthesis (#+ Parser)]]]
    [data
     ["." product]
     ["." maybe ("#@." functor)]
@@ -66,7 +66,7 @@
 (template [<name> <category> <parser>]
   [(def: #export <name>
      (Parser (Type <category>))
-     (<t>.embed <parser> <s>.text))]
+     (<text>.embed <parser> <synthesis>.text))]
 
   [var Var parser.var]
   [class Class parser.class]
@@ -82,7 +82,7 @@
 (def: #export object_array
   (Parser (Type Object))
   (do <>.monad
-    [arrayJT (<t>.embed parser.array <s>.text)]
+    [arrayJT (<text>.embed parser.array <synthesis>.text)]
     (case (parser.array? arrayJT)
       (#.Some elementJT)
       (case (parser.object? elementJT)
@@ -339,7 +339,7 @@
 (def: (primitive_array_length_handler jvm_primitive)
   (-> (Type Primitive) Handler)
   (..custom
-   [<s>.any
+   [<synthesis>.any
     (function (_ extension_name generate archive arrayS)
       (do phase.monad
         [arrayI (generate archive arrayS)]
@@ -350,7 +350,7 @@
 (def: array::length::object
   Handler
   (..custom
-   [($_ <>.and ..object_array <s>.any)
+   [($_ <>.and ..object_array <synthesis>.any)
     (function (_ extension_name generate archive [elementJT arrayS])
       (do phase.monad
         [arrayI (generate archive arrayS)]
@@ -374,7 +374,7 @@
 (def: array::new::object
   Handler
   (..custom
-   [($_ <>.and ..object <s>.any)
+   [($_ <>.and ..object <synthesis>.any)
     (function (_ extension_name generate archive [objectJT lengthS])
       (do phase.monad
         [lengthI (generate archive lengthS)]
@@ -400,7 +400,7 @@
 (def: array::read::object
   Handler
   (..custom
-   [($_ <>.and ..object_array <s>.any <s>.any)
+   [($_ <>.and ..object_array <synthesis>.any <synthesis>.any)
     (function (_ extension_name generate archive [elementJT idxS arrayS])
       (do phase.monad
         [arrayI (generate archive arrayS)
@@ -432,7 +432,7 @@
 (def: array::write::object
   Handler
   (..custom
-   [($_ <>.and ..object_array <s>.any <s>.any <s>.any)
+   [($_ <>.and ..object_array <synthesis>.any <synthesis>.any <synthesis>.any)
     (function (_ extension_name generate archive [elementJT idxS valueS arrayS])
       (do phase.monad
         [arrayI (generate archive arrayS)
@@ -525,7 +525,8 @@
   (|>> exceptionI
        _.ATHROW))
 
-(def: $Class (type.class "java.lang.Class" (list)))
+(def: $Class
+  (type.class "java.lang.Class" (list)))
 
 (def: (object::class extension_name generate archive inputs)
   Handler
@@ -542,7 +543,7 @@
 (def: object::instance?
   Handler
   (..custom
-   [($_ <>.and <s>.text <s>.any)
+   [($_ <>.and <synthesis>.text <synthesis>.any)
     (function (_ extension_name generate archive [class objectS])
       (do phase.monad
         [objectI (generate archive objectS)]
@@ -611,7 +612,7 @@
 (def: get::static
   Handler
   (..custom
-   [($_ <>.and <s>.text <s>.text <s>.text)
+   [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text)
     (function (_ extension_name generate archive [class field unboxed])
       (do phase.monad
         []
@@ -625,7 +626,7 @@
 (def: put::static
   Handler
   (..custom
-   [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
+   [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any)
     (function (_ extension_name generate archive [class field unboxed valueS])
       (do phase.monad
         [valueI (generate archive valueS)
@@ -645,7 +646,7 @@
 (def: get::virtual
   Handler
   (..custom
-   [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
+   [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any)
     (function (_ extension_name generate archive [class field unboxed objectS])
       (do phase.monad
         [objectI (generate archive objectS)
@@ -663,7 +664,7 @@
 (def: put::virtual
   Handler
   (..custom
-   [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any)
+   [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any <synthesis>.any)
     (function (_ extension_name generate archive [class field unboxed valueS objectS])
       (do phase.monad
         [valueI (generate archive valueS)
@@ -683,11 +684,12 @@
                    valueI
                    putI))))]))
 
-(type: Input (Typed Synthesis))
+(type: Input
+  (Typed Synthesis))
 
 (def: input
   (Parser Input)
-  (<s>.tuple (<>.and ..value <s>.any)))
+  (<synthesis>.tuple (<>.and ..value <synthesis>.any)))
 
 (def: (generate_input generate archive [valueT valueS])
   (-> Phase Archive Input
@@ -702,7 +704,8 @@
       (wrap [valueT (|>> valueI
                          (_.CHECKCAST valueT))]))))
 
-(def: voidI (_.string synthesis.unit))
+(def: voidI
+  (_.string synthesis.unit))
 
 (def: (prepare_output outputT)
   (-> (Type Return) Inst)
@@ -716,7 +719,7 @@
 (def: invoke::static
   Handler
   (..custom
-   [($_ <>.and ..class <s>.text ..return (<>.some ..input))
+   [($_ <>.and ..class <synthesis>.text ..return (<>.some ..input))
     (function (_ extension_name generate archive [class method outputT inputsTS])
       (do {@ phase.monad}
         [inputsTI (monad.map @ (generate_input generate archive) inputsTS)]
@@ -728,7 +731,7 @@
   [(def: <name>
      Handler
      (..custom
-      [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input))
+      [($_ <>.and ..class <synthesis>.text ..return <synthesis>.any (<>.some ..input))
        (function (_ extension_name generate archive [class method outputT objectS inputsTS])
          (do {@ phase.monad}
            [objectI (generate archive objectS)
@@ -782,37 +785,38 @@
 
 (def: annotation_parameter
   (Parser (/.Annotation_Parameter Synthesis))
-  (<s>.tuple (<>.and <s>.text <s>.any)))
+  (<synthesis>.tuple (<>.and <synthesis>.text <synthesis>.any)))
 
 (def: annotation
   (Parser (/.Annotation Synthesis))
-  (<s>.tuple (<>.and <s>.text (<>.some ..annotation_parameter))))
+  (<synthesis>.tuple (<>.and <synthesis>.text (<>.some ..annotation_parameter))))
 
 (def: argument
   (Parser Argument)
-  (<s>.tuple (<>.and <s>.text ..value)))
+  (<synthesis>.tuple (<>.and <synthesis>.text ..value)))
 
 (def: overriden_method_definition
   (Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)])
-  (<s>.tuple (do <>.monad
-               [_ (<s>.text! /.overriden_tag)
-                ownerT ..class
-                name <s>.text
-                strict_fp? <s>.bit
-                annotations (<s>.tuple (<>.some ..annotation))
-                vars (<s>.tuple (<>.some ..var))
-                self_name <s>.text
-                arguments (<s>.tuple (<>.some ..argument))
-                returnT ..return
-                exceptionsT (<s>.tuple (<>.some ..class))
-                [environment _ _ body] (<s>.function 1
-                                         (<s>.loop (<>.exactly 0 <s>.any)
-                                           (<s>.tuple <s>.any)))]
-               (wrap [environment
-                      [ownerT name
-                       strict_fp? annotations vars
-                       self_name arguments returnT exceptionsT
-                       body]]))))
+  (<synthesis>.tuple
+   (do <>.monad
+     [_ (<synthesis>.text! /.overriden_tag)
+      ownerT ..class
+      name <synthesis>.text
+      strict_fp? <synthesis>.bit
+      annotations (<synthesis>.tuple (<>.some ..annotation))
+      vars (<synthesis>.tuple (<>.some ..var))
+      self_name <synthesis>.text
+      arguments (<synthesis>.tuple (<>.some ..argument))
+      returnT ..return
+      exceptionsT (<synthesis>.tuple (<>.some ..class))
+      [environment _ _ body] (<synthesis>.function 1
+                               (<synthesis>.loop (<>.exactly 0 <synthesis>.any)
+                                 (<synthesis>.tuple <synthesis>.any)))]
+     (wrap [environment
+            [ownerT name
+             strict_fp? annotations vars
+             self_name arguments returnT exceptionsT
+             body]]))))
 
 (def: (normalize_path normalize)
   (-> (-> Synthesis Synthesis)
@@ -978,9 +982,9 @@
   (..custom
    [($_ <>.and
         ..class
-        (<s>.tuple (<>.some ..class))
-        (<s>.tuple (<>.some ..input))
-        (<s>.tuple (<>.some ..overriden_method_definition)))
+        (<synthesis>.tuple (<>.some ..class))
+        (<synthesis>.tuple (<>.some ..input))
+        (<synthesis>.tuple (<>.some ..overriden_method_definition)))
     (function (_ extension_name generate archive [super_class super_interfaces
                                                   inputsTS
                                                   overriden_methods])
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/function.lux b/lux-jvm/source/luxc/lang/translation/jvm/function.lux
index 0b441c92f..a3583155b 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/function.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/function.lux
@@ -30,7 +30,7 @@
       [lux
        [analysis (#+ Environment)]
        [synthesis (#+ Synthesis Abstraction Apply)]
-       ["." generation]]]
+       ["." generation (#+ Context)]]]
      [meta
       [archive (#+ Archive)]]]]]
   [luxc
@@ -301,13 +301,22 @@
       [instanceI (..instance generate archive classD arity env)]
       (wrap [functionD instanceI]))))
 
-(def: #export (function generate archive [env arity bodyS])
-  (Generator Abstraction)
-  (do phase.monad
+(def: #export (function' forced_context generate archive [env arity bodyS])
+  (-> (Maybe Context) (Generator Abstraction))
+  (do {! phase.monad}
     [@begin _.make_label
-     [function_context bodyI] (generation.with_new_context archive
-                                (generation.with_anchor [@begin 1]
-                                  (generate archive bodyS)))
+     [function_context bodyI] (case forced_context
+                                (#.Some function_context)
+                                (do !
+                                  [without_context (generation.with_anchor [@begin 1]
+                                                     (generate archive bodyS))]
+                                  (wrap [function_context
+                                         without_context]))
+                                
+                                #.None
+                                (generation.with_new_context archive
+                                  (generation.with_anchor [@begin 1]
+                                    (generate archive bodyS))))
      #let [function_class (//.class_name function_context)]
      [functionD instanceI] (..with_function generate archive @begin function_class env arity bodyI)
      #let [directive [function_class
@@ -316,9 +325,18 @@
                                  //.$Function (list)
                                  functionD)]]
      _ (generation.execute! directive)
-     _ (generation.save! (product.right function_context) directive)]
+     _ (case forced_context
+         #.None
+         (generation.save! (product.right function_context) directive)
+
+         (#.Some function_context)
+         (wrap []))]
     (wrap instanceI)))
 
+(def: #export function
+  (Generator Abstraction)
+  (..function' #.None))
+
 (def: #export (call generate archive [functionS argsS])
   (Generator Apply)
   (do {@ phase.monad}
diff --git a/lux-jvm/source/program.lux b/lux-jvm/source/program.lux
index baa76ac31..9dc641d7f 100644
--- a/lux-jvm/source/program.lux
+++ b/lux-jvm/source/program.lux
@@ -21,17 +21,24 @@
     ["." file]
     ["#/." program]]
    [target
-    [jvm
-     [bytecode (#+ Bytecode)]]]
+    ["." jvm #_
+     [bytecode (#+ Bytecode)]
+     ["#/." type
+      ["#/." box]]]]
    [tool
     [compiler
+     [reference (#+)]
+     ["." phase]
      [default
       ["." platform (#+ Platform)]]
      [meta
+      [archive (#+ Archive)]
       ["." packager #_
        ["#" jvm]]]
      [language
       [lux
+       ["$" synthesis (#+ Synthesis)]
+       ["." generation]
        [analysis
         [macro (#+ Expander)]]
        [phase
@@ -62,6 +69,7 @@
      ["." jvm
       ["." runtime]
       ["." expression]
+      ["." function]
       ["#/." program]
       ["translation" extension]]]]])
 
@@ -81,6 +89,11 @@
   (java/lang/Class java/lang/Object)
   (ffi.class_for java/lang/Object))
 
+(def: _apply1_args
+  (Array (java/lang/Class java/lang/Object))
+  (|> (ffi.array (java/lang/Class java/lang/Object) 1)
+      (ffi.array_write 0 _object_class)))
+
 (def: _apply2_args
   (Array (java/lang/Class java/lang/Object))
   (|> (ffi.array (java/lang/Class java/lang/Object) 2)
@@ -111,6 +124,105 @@
                   (ffi.array_write 1 (:coerce java/lang/Object lux)))
               apply_method))))
 
+(def: how_to_wrap_a_phase
+  Synthesis
+  (let [java/lang/String (jvm/type.class "java.lang.String" (list))
+        <java/lang/Class> (jvm/type.array (jvm/type.class "java.lang.Class" (list)))
+        java/lang/Object (jvm/type.class "java.lang.Object" (list))
+        <java/lang/Object> (jvm/type.array java/lang/Object)
+
+        jvm_type (: (All [c] (-> (jvm/type.Type c) Synthesis))
+                    (|>> jvm/type.format
+                         $.text))
+        class_type (: (-> Text Synthesis)
+                      (function (_ name)
+                        (|> (jvm/type.class name (list))
+                            jvm_type)))
+        unwrap_long (: (-> Synthesis Synthesis)
+                       (|>> (list ($.text jvm/type/box.long)
+                                  ($.text "long"))
+                            (#$.Extension "jvm object cast")))
+        long_to_int (: (-> Synthesis Synthesis)
+                       (|>> (list)
+                            (#$.Extension "jvm conversion long-to-int")))
+        literal_nat (: (-> Nat Synthesis)
+                       (|>> .i64 $.i64 unwrap_long long_to_int))
+        array_write (: (-> Text Nat Synthesis Synthesis Synthesis)
+                       (function (_ element_class index value array)
+                         ((#$.Extension "jvm array write object"
+                                        (list (jvm_type (jvm/type.array (jvm/type.class element_class (list))))
+                                              (literal_nat index)
+                                              value
+                                              array)))))
+        object_array (: (-> Text Nat Synthesis)
+                        (function (_ class_name size)
+                          (#$.Extension "jvm array new object"
+                                        (list (class_type class_name)
+                                              (literal_nat size)))))
+        class_of (: (-> Synthesis Synthesis)
+                    (function (_ object)
+                      (#$.Extension "jvm member invoke virtual"
+                                    (list& (class_type "java.lang.Object")
+                                           ($.text "getClass")
+                                           (class_type "java.lang.Class")
+                                           object
+                                           (list)))))
+        input (: (All [c] (-> (jvm/type.Type c) Synthesis Synthesis))
+                 (function (_ value_type value)
+                   ($.tuple (list (jvm_type value_type) value))))
+        
+        example_object (#$.Extension "jvm member invoke constructor"
+                                     (list& (class_type "java.lang.Object")
+                                            (list)))
+        phase_arity 3
+        $phase ($.variable/local 1)
+        $archive ($.variable/local 2)
+        $input ($.variable/local 3)
+        $state ($.variable/local 4)
+        apply_method (#$.Extension "jvm member invoke virtual"
+                                   (list& (class_type "java.lang.Class")
+                                          ($.text "getMethod")
+                                          (class_type "java.lang.reflect.Method")
+                                          (class_of $phase)
+                                          (list (input java/lang/String
+                                                       ($.text runtime.apply_method))
+                                                (input <java/lang/Class>
+                                                       (|> (object_array "java.lang.Class" phase_arity)
+                                                           (array_write "java.lang.Class" 0 (class_of example_object))
+                                                           (array_write "java.lang.Class" 1 (class_of example_object))
+                                                           (array_write "java.lang.Class" 2 (class_of example_object)))))))]
+    (#$.Extension "jvm member invoke virtual"
+                  (list& (class_type "java.lang.reflect.Method")
+                         ($.text "invoke")
+                         (class_type "java.lang.Object")
+                         apply_method
+                         (list (input java/lang/Object
+                                      $phase)
+                               (input <java/lang/Object>
+                                      (|> (object_array "java.lang.Object" phase_arity)
+                                          (array_write "java.lang.Object" 0 $archive)
+                                          (array_write "java.lang.Object" 1 $input)
+                                          (array_write "java.lang.Object" 2 $state))))))))
+
+(def: (phase_wrapper archive)
+  (-> Archive (generation.Operation _.Anchor _.Inst _.Definition platform.Phase_Wrapper))
+  (do phase.monad
+    [instanceG (function.function' (#.Some [0 (.nat -1)]) expression.translate archive [(list) 4 ..how_to_wrap_a_phase])
+     phase_wrapper (generation.evaluate! [0 (.nat -2)] instanceG)]
+    (wrap (function (_ phase)
+            (<| try.assume
+                (: (Try java/lang/Object))
+                (do try.monad
+                  [apply_method (|> phase_wrapper
+                                    (:coerce java/lang/Object)
+                                    (java/lang/Object::getClass)
+                                    (java/lang/Class::getMethod runtime.apply_method _apply1_args))]
+                  (java/lang/reflect/Method::invoke
+                   (:coerce java/lang/Object phase_wrapper)
+                   (|> (ffi.array java/lang/Object 1)
+                       (ffi.array_write 0 (:coerce java/lang/Object phase)))
+                   apply_method)))))))
+
 (def: #export platform
   ## (IO (Platform Anchor (Bytecode Any) Definition))
   (IO (Platform _.Anchor _.Inst _.Definition))
@@ -123,10 +235,11 @@
            #platform.phase expression.translate
            ## #platform.runtime runtime.generate
            #platform.runtime runtime.translate
+           #platform.phase_wrapper ..phase_wrapper
            #platform.write product.right})))
 
-(def: extender
-  Extender
+(def: (extender phase_wrapper)
+  (-> platform.Phase_Wrapper Extender)
   ## TODO: Stop relying on coercions ASAP.
   (<| (:coerce Extender)
       (function (@self handler))
@@ -148,7 +261,7 @@
          (:coerce java/lang/Object handler)
          (|> (ffi.array java/lang/Object 5)
              (ffi.array_write 0 (:coerce java/lang/Object name))
-             (ffi.array_write 1 (:coerce java/lang/Object phase))
+             (ffi.array_write 1 (:coerce java/lang/Object (phase_wrapper phase)))
              (ffi.array_write 2 (:coerce java/lang/Object archive))
              (ffi.array_write 3 (:coerce java/lang/Object parameters))
              (ffi.array_write 4 (:coerce java/lang/Object state)))
@@ -173,7 +286,7 @@
                            ..platform
                            ## generation.bundle
                            translation.bundle
-                           (directive.bundle ..extender)
+                           (|>> ..extender directive.bundle)
                            (jvm/program.program jvm/runtime.class_name)
                            [_.Anchor _.Inst _.Definition]
                            ..extender