path: root/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux

(.module:
  [library
   [lux (#- Type primitive int char type)
    [ffi (#+ import:)]
    [abstract
     ["." monad (#+ do)]]
    [control
     ["." maybe ("#\." functor)]
     ["." exception (#+ exception:)]
     ["." function]
     ["<>" parser ("#\." monad)
      ["<.>" text]
      ["<.>" synthesis (#+ Parser)]]]
    [data
     ["." product]
     ["." text ("#\." equivalence)
      ["%" format (#+ format)]]
     [collection
      ["." list ("#\." monad mix)]
      ["." dictionary (#+ Dictionary)]
      ["." set]]]
    [macro
     ["." template]]
    [math
     [number
      ["n" nat]]]
    [target
     [jvm
      ["." type (#+ Type Typed Argument)
       ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]
       ["." box]
       ["." reflection]
       ["." signature]
       ["." descriptor]
       ["." parser]]]]
    [tool
     [compiler
      ["." phase ("#\." monad)]
      [reference (#+)
       ["." variable (#+ Variable Register)]]
      [meta
       [archive (#+ Archive)]]
      [language
       [lux
        [analysis (#+ Environment)]
        ["." synthesis (#+ Synthesis Path %synthesis)]
        ["." generation]
        [phase
         [generation
          [extension (#+ Nullary Unary Binary
                         nullary unary binary)]]
         [analysis
          [".A" reference]]
         ["." extension
          ["." bundle]
          [analysis
           ["/" jvm]]]]]]]]]]
  [luxc
   [lang
    [host
     ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase)
      ["_" inst]
      ["_." def]]]]]
  ["." // #_
   [common (#+ custom)]
   ["/#" //
    ["#." reference]
    ["#." function]]])

(template [<name> <category> <parser>]
  [(def: .public <name>
     (Parser (Type <category>))
     (<text>.then <parser> <synthesis>.text))]

  [var Var parser.var]
  [class Class parser.class]
  [object Object parser.object]
  [value Value parser.value]
  [return Return parser.return]
  )

(def: signature
  (All [a] (-> (Type a) Text))
  (|>> type.signature signature.signature))

(def: descriptor
  (All [a] (-> (Type a) Text))
  (|>> type.descriptor descriptor.descriptor))

(exception: .public (not_an_object_array {arrayJT (Type Array)})
  (exception.report
   ["JVM Type" (..signature arrayJT)]))

(def: .public object_array
  (Parser (Type Object))
  (do <>.monad
    [arrayJT (<text>.then parser.array <synthesis>.text)]
    (case (parser.array? arrayJT)
      (#.Some elementJT)
      (case (parser.object? elementJT)
        (#.Some elementJT)
        (in elementJT)

        #.None
        (<>.failure (exception.error ..not_an_object_array [arrayJT])))
      
      #.None
      (undefined))))

(template [<name> <inst>]
  [(def: <name>
     Inst
     (|>> _.L2I <inst>))]

  [L2S _.I2S]
  [L2B _.I2B]
  [L2C _.I2C]
  )

(template [<conversion> <name>]
  [(def: (<name> inputI)
     (Unary Inst)
     (if (same? _.NOP <conversion>)
       inputI
       (|>> inputI
            <conversion>)))]
  
  [_.D2F conversion::double_to_float]
  [_.D2I conversion::double_to_int]
  [_.D2L conversion::double_to_long]
  [_.F2D conversion::float_to_double]
  [_.F2I conversion::float_to_int]
  [_.F2L conversion::float_to_long]
  [_.I2B conversion::int_to_byte]
  [_.I2C conversion::int_to_char]
  [_.I2D conversion::int_to_double]
  [_.I2F conversion::int_to_float]
  [_.I2L conversion::int_to_long]
  [_.I2S conversion::int_to_short]
  [_.L2D conversion::long_to_double]
  [_.L2F conversion::long_to_float]
  [_.L2I conversion::long_to_int]
  [..L2S conversion::long_to_short]
  [..L2B conversion::long_to_byte]
  [..L2C conversion::long_to_char]
  [_.I2B conversion::char_to_byte]
  [_.I2S conversion::char_to_short]
  [_.NOP conversion::char_to_int]
  [_.I2L conversion::char_to_long]
  [_.I2L conversion::byte_to_long]
  [_.I2L conversion::short_to_long]
  )

(def: conversion_bundle
  Bundle
  (<| (bundle.prefix "conversion")
      (|> (: Bundle bundle.empty)
          (bundle.install "double-to-float" (unary conversion::double_to_float))
          (bundle.install "double-to-int" (unary conversion::double_to_int))
          (bundle.install "double-to-long" (unary conversion::double_to_long))
          (bundle.install "float-to-double" (unary conversion::float_to_double))
          (bundle.install "float-to-int" (unary conversion::float_to_int))
          (bundle.install "float-to-long" (unary conversion::float_to_long))
          (bundle.install "int-to-byte" (unary conversion::int_to_byte))
          (bundle.install "int-to-char" (unary conversion::int_to_char))
          (bundle.install "int-to-double" (unary conversion::int_to_double))
          (bundle.install "int-to-float" (unary conversion::int_to_float))
          (bundle.install "int-to-long" (unary conversion::int_to_long))
          (bundle.install "int-to-short" (unary conversion::int_to_short))
          (bundle.install "long-to-double" (unary conversion::long_to_double))
          (bundle.install "long-to-float" (unary conversion::long_to_float))
          (bundle.install "long-to-int" (unary conversion::long_to_int))
          (bundle.install "long-to-short" (unary conversion::long_to_short))
          (bundle.install "long-to-byte" (unary conversion::long_to_byte))
          (bundle.install "long-to-char" (unary conversion::long_to_char))
          (bundle.install "char-to-byte" (unary conversion::char_to_byte))
          (bundle.install "char-to-short" (unary conversion::char_to_short))
          (bundle.install "char-to-int" (unary conversion::char_to_int))
          (bundle.install "char-to-long" (unary conversion::char_to_long))
          (bundle.install "byte-to-long" (unary conversion::byte_to_long))
          (bundle.install "short-to-long" (unary conversion::short_to_long))
          )))

(template [<name> <op>]
  [(def: (<name> [parameterI subject1])
     (Binary Inst)
     (|>> subject1
          parameterI
          <op>))]

  [int::+ _.IADD]
  [int::- _.ISUB]
  [int::* _.IMUL]
  [int::/ _.IDIV]
  [int::% _.IREM]
  [int::and _.IAND]
  [int::or _.IOR]
  [int::xor _.IXOR]
  [int::shl _.ISHL]
  [int::shr _.ISHR]
  [int::ushr _.IUSHR]
  
  [long::+ _.LADD]
  [long::- _.LSUB]
  [long::* _.LMUL]
  [long::/ _.LDIV]
  [long::% _.LREM]
  [long::and _.LAND]
  [long::or _.LOR]
  [long::xor _.LXOR]
  [long::shl _.LSHL]
  [long::shr _.LSHR]
  [long::ushr _.LUSHR]

  [float::+ _.FADD]
  [float::- _.FSUB]
  [float::* _.FMUL]
  [float::/ _.FDIV]
  [float::% _.FREM]
  
  [double::+ _.DADD]
  [double::- _.DSUB]
  [double::* _.DMUL]
  [double::/ _.DDIV]
  [double::% _.DREM]
  )

(def: $Boolean (type.class box.boolean (list)))
(def: falseI (_.GETSTATIC $Boolean "FALSE" $Boolean))
(def: trueI (_.GETSTATIC $Boolean "TRUE" $Boolean))

(template [<name> <op>]
  [(def: (<name> [referenceI subjectI])
     (Binary Inst)
     (<| _.with_label (function (_ @then))
         _.with_label (function (_ @end))
         (|>> subjectI
              referenceI
              (<op> @then)
              falseI
              (_.GOTO @end)
              (_.label @then)
              trueI
              (_.label @end))))]

  [int::= _.IF_ICMPEQ]
  [int::< _.IF_ICMPLT]

  [char::= _.IF_ICMPEQ]
  [char::< _.IF_ICMPLT]
  )

(template [<name> <op> <reference>]
  [(def: (<name> [referenceI subjectI])
     (Binary Inst)
     (<| _.with_label (function (_ @then))
         _.with_label (function (_ @end))
         (|>> subjectI
              referenceI
              <op>
              (_.int <reference>)
              (_.IF_ICMPEQ @then)
              falseI
              (_.GOTO @end)
              (_.label @then)
              trueI
              (_.label @end))))]

  [long::= _.LCMP +0]
  [long::< _.LCMP -1]
  
  [float::= _.FCMPG +0]
  [float::< _.FCMPG -1]

  [double::= _.DCMPG +0]
  [double::< _.DCMPG -1]
  )

(def: int_bundle
  Bundle
  (<| (bundle.prefix (reflection.reflection reflection.int))
      (|> (: Bundle bundle.empty)
          (bundle.install "+" (binary int::+))
          (bundle.install "-" (binary int::-))
          (bundle.install "*" (binary int::*))
          (bundle.install "/" (binary int::/))
          (bundle.install "%" (binary int::%))
          (bundle.install "=" (binary int::=))
          (bundle.install "<" (binary int::<))
          (bundle.install "and" (binary int::and))
          (bundle.install "or" (binary int::or))
          (bundle.install "xor" (binary int::xor))
          (bundle.install "shl" (binary int::shl))
          (bundle.install "shr" (binary int::shr))
          (bundle.install "ushr" (binary int::ushr))
          )))

(def: long_bundle
  Bundle
  (<| (bundle.prefix (reflection.reflection reflection.long))
      (|> (: Bundle bundle.empty)
          (bundle.install "+" (binary long::+))
          (bundle.install "-" (binary long::-))
          (bundle.install "*" (binary long::*))
          (bundle.install "/" (binary long::/))
          (bundle.install "%" (binary long::%))
          (bundle.install "=" (binary long::=))
          (bundle.install "<" (binary long::<))
          (bundle.install "and" (binary long::and))
          (bundle.install "or" (binary long::or))
          (bundle.install "xor" (binary long::xor))
          (bundle.install "shl" (binary long::shl))
          (bundle.install "shr" (binary long::shr))
          (bundle.install "ushr" (binary long::ushr))
          )))

(def: float_bundle
  Bundle
  (<| (bundle.prefix (reflection.reflection reflection.float))
      (|> (: Bundle bundle.empty)
          (bundle.install "+" (binary float::+))
          (bundle.install "-" (binary float::-))
          (bundle.install "*" (binary float::*))
          (bundle.install "/" (binary float::/))
          (bundle.install "%" (binary float::%))
          (bundle.install "=" (binary float::=))
          (bundle.install "<" (binary float::<))
          )))

(def: double_bundle
  Bundle
  (<| (bundle.prefix (reflection.reflection reflection.double))
      (|> (: Bundle bundle.empty)
          (bundle.install "+" (binary double::+))
          (bundle.install "-" (binary double::-))
          (bundle.install "*" (binary double::*))
          (bundle.install "/" (binary double::/))
          (bundle.install "%" (binary double::%))
          (bundle.install "=" (binary double::=))
          (bundle.install "<" (binary double::<))
          )))

(def: char_bundle
  Bundle
  (<| (bundle.prefix (reflection.reflection reflection.char))
      (|> (: Bundle bundle.empty)
          (bundle.install "=" (binary char::=))
          (bundle.install "<" (binary char::<))
          )))

(def: (primitive_array_length_handler jvm_primitive)
  (-> (Type Primitive) Handler)
  (..custom
   [<synthesis>.any
    (function (_ extension_name generate archive arrayS)
      (do phase.monad
        [arrayI (generate archive arrayS)]
        (in (|>> arrayI
                 (_.CHECKCAST (type.array jvm_primitive))
                 _.ARRAYLENGTH))))]))

(def: array::length::object
  Handler
  (..custom
   [($_ <>.and ..object_array <synthesis>.any)
    (function (_ extension_name generate archive [elementJT arrayS])
      (do phase.monad
        [arrayI (generate archive arrayS)]
        (in (|>> arrayI
                 (_.CHECKCAST (type.array elementJT))
                 _.ARRAYLENGTH))))]))

(def: (new_primitive_array_handler jvm_primitive)
  (-> (Type Primitive) Handler)
  (function (_ extension_name generate archive inputs)
    (case inputs
      (^ (list lengthS))
      (do phase.monad
        [lengthI (generate archive lengthS)]
        (in (|>> lengthI
                 (_.array jvm_primitive))))

      _
      (phase.except extension.invalid_syntax [extension_name %synthesis inputs]))))

(def: array::new::object
  Handler
  (..custom
   [($_ <>.and ..object <synthesis>.any)
    (function (_ extension_name generate archive [objectJT lengthS])
      (do phase.monad
        [lengthI (generate archive lengthS)]
        (in (|>> lengthI
                 (_.ANEWARRAY objectJT)))))]))

(def: (read_primitive_array_handler jvm_primitive loadI)
  (-> (Type Primitive) Inst Handler)
  (function (_ extension_name generate archive inputs)
    (case inputs
      (^ (list idxS arrayS))
      (do phase.monad
        [arrayI (generate archive arrayS)
         idxI (generate archive idxS)]
        (in (|>> arrayI
                 (_.CHECKCAST (type.array jvm_primitive))
                 idxI
                 loadI)))

      _
      (phase.except extension.invalid_syntax [extension_name %synthesis inputs]))))

(def: array::read::object
  Handler
  (..custom
   [($_ <>.and ..object_array <synthesis>.any <synthesis>.any)
    (function (_ extension_name generate archive [elementJT idxS arrayS])
      (do phase.monad
        [arrayI (generate archive arrayS)
         idxI (generate archive idxS)]
        (in (|>> arrayI
                 (_.CHECKCAST (type.array elementJT))
                 idxI
                 _.AALOAD))))]))

(def: (write_primitive_array_handler jvm_primitive storeI)
  (-> (Type Primitive) Inst Handler)
  (function (_ extension_name generate archive inputs)
    (case inputs
      (^ (list idxS valueS arrayS))
      (do phase.monad
        [arrayI (generate archive arrayS)
         idxI (generate archive idxS)
         valueI (generate archive valueS)]
        (in (|>> arrayI
                 (_.CHECKCAST (type.array jvm_primitive))
                 _.DUP
                 idxI
                 valueI
                 storeI)))

      _
      (phase.except extension.invalid_syntax [extension_name %synthesis inputs]))))

(def: array::write::object
  Handler
  (..custom
   [($_ <>.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)
         idxI (generate archive idxS)
         valueI (generate archive valueS)]
        (in (|>> arrayI
                 (_.CHECKCAST (type.array elementJT))
                 _.DUP
                 idxI
                 valueI
                 _.AASTORE))))]))

(def: array_bundle
  Bundle
  (<| (bundle.prefix "array")
      (|> bundle.empty
          (dictionary.merged (<| (bundle.prefix "length")
                                 (|> bundle.empty
                                     (bundle.install (reflection.reflection reflection.boolean) (primitive_array_length_handler type.boolean))
                                     (bundle.install (reflection.reflection reflection.byte) (primitive_array_length_handler type.byte))
                                     (bundle.install (reflection.reflection reflection.short) (primitive_array_length_handler type.short))
                                     (bundle.install (reflection.reflection reflection.int) (primitive_array_length_handler type.int))
                                     (bundle.install (reflection.reflection reflection.long) (primitive_array_length_handler type.long))
                                     (bundle.install (reflection.reflection reflection.float) (primitive_array_length_handler type.float))
                                     (bundle.install (reflection.reflection reflection.double) (primitive_array_length_handler type.double))
                                     (bundle.install (reflection.reflection reflection.char) (primitive_array_length_handler type.char))
                                     (bundle.install "object" array::length::object))))
          (dictionary.merged (<| (bundle.prefix "new")
                                 (|> bundle.empty
                                     (bundle.install (reflection.reflection reflection.boolean) (new_primitive_array_handler type.boolean))
                                     (bundle.install (reflection.reflection reflection.byte) (new_primitive_array_handler type.byte))
                                     (bundle.install (reflection.reflection reflection.short) (new_primitive_array_handler type.short))
                                     (bundle.install (reflection.reflection reflection.int) (new_primitive_array_handler type.int))
                                     (bundle.install (reflection.reflection reflection.long) (new_primitive_array_handler type.long))
                                     (bundle.install (reflection.reflection reflection.float) (new_primitive_array_handler type.float))
                                     (bundle.install (reflection.reflection reflection.double) (new_primitive_array_handler type.double))
                                     (bundle.install (reflection.reflection reflection.char) (new_primitive_array_handler type.char))
                                     (bundle.install "object" array::new::object))))
          (dictionary.merged (<| (bundle.prefix "read")
                                 (|> bundle.empty
                                     (bundle.install (reflection.reflection reflection.boolean) (read_primitive_array_handler type.boolean _.BALOAD))
                                     (bundle.install (reflection.reflection reflection.byte) (read_primitive_array_handler type.byte _.BALOAD))
                                     (bundle.install (reflection.reflection reflection.short) (read_primitive_array_handler type.short _.SALOAD))
                                     (bundle.install (reflection.reflection reflection.int) (read_primitive_array_handler type.int _.IALOAD))
                                     (bundle.install (reflection.reflection reflection.long) (read_primitive_array_handler type.long _.LALOAD))
                                     (bundle.install (reflection.reflection reflection.float) (read_primitive_array_handler type.float _.FALOAD))
                                     (bundle.install (reflection.reflection reflection.double) (read_primitive_array_handler type.double _.DALOAD))
                                     (bundle.install (reflection.reflection reflection.char) (read_primitive_array_handler type.char _.CALOAD))
                                     (bundle.install "object" array::read::object))))
          (dictionary.merged (<| (bundle.prefix "write")
                                 (|> bundle.empty
                                     (bundle.install (reflection.reflection reflection.boolean) (write_primitive_array_handler type.boolean _.BASTORE))
                                     (bundle.install (reflection.reflection reflection.byte) (write_primitive_array_handler type.byte _.BASTORE))
                                     (bundle.install (reflection.reflection reflection.short) (write_primitive_array_handler type.short _.SASTORE))
                                     (bundle.install (reflection.reflection reflection.int) (write_primitive_array_handler type.int _.IASTORE))
                                     (bundle.install (reflection.reflection reflection.long) (write_primitive_array_handler type.long _.LASTORE))
                                     (bundle.install (reflection.reflection reflection.float) (write_primitive_array_handler type.float _.FASTORE))
                                     (bundle.install (reflection.reflection reflection.double) (write_primitive_array_handler type.double _.DASTORE))
                                     (bundle.install (reflection.reflection reflection.char) (write_primitive_array_handler type.char _.CASTORE))
                                     (bundle.install "object" array::write::object))))
          )))

(def: (object::null _)
  (Nullary Inst)
  _.NULL)

(def: (object::null? objectI)
  (Unary Inst)
  (<| _.with_label (function (_ @then))
      _.with_label (function (_ @end))
      (|>> objectI
           (_.IFNULL @then)
           falseI
           (_.GOTO @end)
           (_.label @then)
           trueI
           (_.label @end))))

(def: (object::synchronized [monitorI exprI])
  (Binary Inst)
  (|>> monitorI
       _.DUP
       _.MONITORENTER
       exprI
       _.SWAP
       _.MONITOREXIT))

(def: (object::throw exceptionI)
  (Unary Inst)
  (|>> exceptionI
       _.ATHROW))

(def: $Class
  (type.class "java.lang.Class" (list)))

(def: (object::class extension_name generate archive inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class)))
    (do phase.monad
      []
      (in (|>> (_.string class)
               (_.INVOKESTATIC $Class "forName" (type.method [(list) (list (type.class "java.lang.String" (list))) $Class (list)])))))

    _
    (phase.except extension.invalid_syntax [extension_name %synthesis inputs])))

(def: object::instance?
  Handler
  (..custom
   [($_ <>.and <synthesis>.text <synthesis>.any)
    (function (_ extension_name generate archive [class objectS])
      (do phase.monad
        [objectI (generate archive objectS)]
        (in (|>> objectI
                 (_.INSTANCEOF (type.class class (list)))
                 (_.wrap type.boolean)))))]))

(def: (object::cast extension_name generate archive inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text from) (synthesis.text to) valueS))
    (do phase.monad
      [valueI (generate archive valueS)]
      (`` (cond (~~ (template [<object> <primitive>]
                      [(and (text\= (reflection.reflection (type.reflection <primitive>))
                                    from)
                            (text\= <object>
                                    to))
                       (in (|>> valueI (_.wrap <primitive>)))

                       (and (text\= <object>
                                    from)
                            (text\= (reflection.reflection (type.reflection <primitive>))
                                    to))
                       (in (|>> valueI (_.unwrap <primitive>)))]
                      
                      [box.boolean type.boolean]
                      [box.byte    type.byte]
                      [box.short   type.short]
                      [box.int     type.int]
                      [box.long    type.long]
                      [box.float   type.float]
                      [box.double  type.double]
                      [box.char    type.char]))
                ... else
                (in valueI))))

    _
    (phase.except extension.invalid_syntax [extension_name %synthesis inputs])))

(def: object_bundle
  Bundle
  (<| (bundle.prefix "object")
      (|> (: Bundle bundle.empty)
          (bundle.install "null" (nullary object::null))
          (bundle.install "null?" (unary object::null?))
          (bundle.install "synchronized" (binary object::synchronized))
          (bundle.install "throw" (unary object::throw))
          (bundle.install "class" object::class)
          (bundle.install "instance?" object::instance?)
          (bundle.install "cast" object::cast)
          )))

(def: primitives
  (Dictionary Text (Type Primitive))
  (|> (list [(reflection.reflection reflection.boolean) type.boolean]
            [(reflection.reflection reflection.byte) type.byte]
            [(reflection.reflection reflection.short) type.short]
            [(reflection.reflection reflection.int) type.int]
            [(reflection.reflection reflection.long) type.long]
            [(reflection.reflection reflection.float) type.float]
            [(reflection.reflection reflection.double) type.double]
            [(reflection.reflection reflection.char) type.char])
      (dictionary.of_list text.hash)))

(def: get::static
  Handler
  (..custom
   [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text)
    (function (_ extension_name generate archive [class field unboxed])
      (do phase.monad
        []
        (case (dictionary.value unboxed ..primitives)
          (#.Some primitive)
          (in (_.GETSTATIC (type.class class (list)) field primitive))
          
          #.None
          (in (_.GETSTATIC (type.class class (list)) field (type.class unboxed (list)))))))]))

(def: put::static
  Handler
  (..custom
   [($_ <>.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)
         .let [$class (type.class class (list))]]
        (case (dictionary.value unboxed ..primitives)
          (#.Some primitive)
          (in (|>> valueI
                   (_.PUTSTATIC $class field primitive)
                   (_.string synthesis.unit)))
          
          #.None
          (in (|>> valueI
                   (_.CHECKCAST $class)
                   (_.PUTSTATIC $class field $class)
                   (_.string synthesis.unit))))))]))

(def: get::virtual
  Handler
  (..custom
   [($_ <>.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)
         .let [$class (type.class class (list))
               getI (case (dictionary.value unboxed ..primitives)
                      (#.Some primitive)
                      (_.GETFIELD $class field primitive)
                      
                      #.None
                      (_.GETFIELD $class field (type.class unboxed (list))))]]
        (in (|>> objectI
                 (_.CHECKCAST $class)
                 getI))))]))

(def: put::virtual
  Handler
  (..custom
   [($_ <>.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)
         objectI (generate archive objectS)
         .let [$class (type.class class (list))
               putI (case (dictionary.value unboxed ..primitives)
                      (#.Some primitive)
                      (_.PUTFIELD $class field primitive)
                      
                      #.None
                      (let [$unboxed (type.class unboxed (list))]
                        (|>> (_.CHECKCAST $unboxed)
                             (_.PUTFIELD $class field $unboxed))))]]
        (in (|>> objectI
                 (_.CHECKCAST $class)
                 _.DUP
                 valueI
                 putI))))]))

(type: Input
  (Typed Synthesis))

(def: input
  (Parser Input)
  (<synthesis>.tuple (<>.and ..value <synthesis>.any)))

(def: (generate_input generate archive [valueT valueS])
  (-> Phase Archive Input
      (Operation (Typed Inst)))
  (do phase.monad
    [valueI (generate archive valueS)]
    (case (type.primitive? valueT)
      (#.Right valueT)
      (in [valueT valueI])
      
      (#.Left valueT)
      (in [valueT (|>> valueI
                       (_.CHECKCAST valueT))]))))

(def: voidI
  (_.string synthesis.unit))

(def: (prepare_output outputT)
  (-> (Type Return) Inst)
  (case (type.void? outputT)
    (#.Right outputT)
    ..voidI
    
    (#.Left outputT)
    function.identity))

(def: invoke::static
  Handler
  (..custom
   [($_ <>.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)]
        (in (|>> (_.fuse (list\map product.right inputsTI))
                 (_.INVOKESTATIC class method (type.method [(list) (list\map product.left inputsTI) outputT (list)]))
                 (prepare_output outputT)))))]))

(template [<name> <invoke>]
  [(def: <name>
     Handler
     (..custom
      [($_ <>.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)
            inputsTI (monad.map ! (generate_input generate archive) inputsTS)]
           (in (|>> objectI
                    (_.CHECKCAST class)
                    (_.fuse (list\map product.right inputsTI))
                    (<invoke> class method
                              (type.method [(list)
                                            (list\map product.left inputsTI)
                                            outputT
                                            (list)]))
                    (prepare_output outputT)))))]))]

  [invoke::virtual _.INVOKEVIRTUAL]
  [invoke::special _.INVOKESPECIAL]
  [invoke::interface _.INVOKEINTERFACE]
  )

(def: invoke::constructor
  Handler
  (..custom
   [($_ <>.and ..class (<>.some ..input))
    (function (_ extension_name generate archive [class inputsTS])
      (do {! phase.monad}
        [inputsTI (monad.map ! (generate_input generate archive) inputsTS)]
        (in (|>> (_.NEW class)
                 _.DUP
                 (_.fuse (list\map product.right inputsTI))
                 (_.INVOKESPECIAL class "<init>" (type.method [(list) (list\map product.left inputsTI) type.void (list)]))))))]))

(def: member_bundle
  Bundle
  (<| (bundle.prefix "member")
      (|> (: Bundle bundle.empty)
          (dictionary.merged (<| (bundle.prefix "get")
                                 (|> (: Bundle bundle.empty)
                                     (bundle.install "static" get::static)
                                     (bundle.install "virtual" get::virtual))))
          (dictionary.merged (<| (bundle.prefix "put")
                                 (|> (: Bundle bundle.empty)
                                     (bundle.install "static" put::static)
                                     (bundle.install "virtual" put::virtual))))
          (dictionary.merged (<| (bundle.prefix "invoke")
                                 (|> (: Bundle bundle.empty)
                                     (bundle.install "static" invoke::static)
                                     (bundle.install "virtual" invoke::virtual)
                                     (bundle.install "special" invoke::special)
                                     (bundle.install "interface" invoke::interface)
                                     (bundle.install "constructor" invoke::constructor))))
          )))

(def: annotation_parameter
  (Parser (/.Annotation_Parameter Synthesis))
  (<synthesis>.tuple (<>.and <synthesis>.text <synthesis>.any)))

(def: annotation
  (Parser (/.Annotation Synthesis))
  (<synthesis>.tuple (<>.and <synthesis>.text (<>.some ..annotation_parameter))))

(def: argument
  (Parser Argument)
  (<synthesis>.tuple (<>.and <synthesis>.text ..value)))

(def: .public (hidden_method_body arity body)
  (-> Nat Synthesis Synthesis)
  (case [arity body]
    [0 _] body
    [1 _] body
    
    [2 (#synthesis.Control (#synthesis.Branch (#synthesis.Let _ 2 hidden)))]
    hidden
    
    [_ (#synthesis.Control (#synthesis.Branch (#synthesis.Case _ path)))]
    (loop [path path]
      (case path
        (^or #synthesis.Pop
             (#synthesis.Access _)
             (#synthesis.Bind _)
             (#synthesis.Bit_Fork _)
             (#synthesis.I64_Fork _)
             (#synthesis.F64_Fork _)
             (#synthesis.Text_Fork _)
             (#synthesis.Alt _))
        body
        
        (#synthesis.Seq _ next)
        (recur next)
        
        (#synthesis.Then hidden)
        hidden))

    _
    body))

(def: overriden_method_definition
  (Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)])
  (<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
                                 (<>.after <synthesis>.any)
                                 <synthesis>.any)]
     (in [environment
          [ownerT name
           strict_fp? annotations vars
           self_name arguments returnT exceptionsT
           (..hidden_method_body (list.size arguments) body)]]))))

(def: (normalize_path normalize)
  (-> (-> Synthesis Synthesis)
      (-> Path Path))
  (function (recur path)
    (case path
      (^ (synthesis.path/then bodyS))
      (synthesis.path/then (normalize bodyS))

      (^template [<tag>]
        [(^ (<tag> leftP rightP))
         (<tag> (recur leftP) (recur rightP))])
      ([#synthesis.Alt]
       [#synthesis.Seq])

      (^template [<tag>]
        [(^ (<tag> value))
         path])
      ([#synthesis.Pop]
       [#synthesis.Bind]
       [#synthesis.Access])

      (#synthesis.Bit_Fork when then else)
      (#synthesis.Bit_Fork when (recur then) (maybe\map recur else))

      (^template [<tag>]
        [(<tag> [[test then] elses])
         (<tag> [[test (recur then)]
                 (list\map (function (_ [else_test else_then])
                             [else_test (recur else_then)])
                           elses)])])
      ([#synthesis.I64_Fork]
       [#synthesis.F64_Fork]
       [#synthesis.Text_Fork])
      )))

(def: (normalize_method_body mapping)
  (-> (Dictionary Synthesis Variable) Synthesis Synthesis)
  (function (recur body)
    (case body
      (^template [<tag>]
        [(^ (<tag> value))
         body])
      ([#synthesis.Primitive]
       [synthesis.constant])

      (^ (synthesis.variant [lefts right? sub]))
      (synthesis.variant [lefts right? (recur sub)])

      (^ (synthesis.tuple members))
      (synthesis.tuple (list\map recur members))

      (^ (synthesis.variable var))
      (|> mapping
          (dictionary.value body)
          (maybe.else var)
          synthesis.variable)

      (^ (synthesis.branch/case [inputS pathS]))
      (synthesis.branch/case [(recur inputS) (normalize_path recur pathS)])

      (^ (synthesis.branch/let [inputS register outputS]))
      (synthesis.branch/let [(recur inputS) register (recur outputS)])

      (^ (synthesis.branch/if [testS thenS elseS]))
      (synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)])

      (^ (synthesis.branch/get [path recordS]))
      (synthesis.branch/get [path (recur recordS)])

      (^ (synthesis.loop/scope [offset initsS+ bodyS]))
      (synthesis.loop/scope [offset (list\map recur initsS+) (recur bodyS)])

      (^ (synthesis.loop/recur updatesS+))
      (synthesis.loop/recur (list\map recur updatesS+))

      (^ (synthesis.function/abstraction [environment arity bodyS]))
      (synthesis.function/abstraction [(list\map (function (_ captured)
                                                   (case captured
                                                     (^ (synthesis.variable var))
                                                     (|> mapping
                                                         (dictionary.value captured)
                                                         (maybe.else var)
                                                         synthesis.variable)

                                                     _
                                                     captured))
                                                 environment)
                                       arity
                                       bodyS])

      (^ (synthesis.function/apply [functionS inputsS+]))
      (synthesis.function/apply [(recur functionS) (list\map recur inputsS+)])

      (#synthesis.Extension [name inputsS+])
      (#synthesis.Extension [name (list\map recur inputsS+)]))))

(def: $Object
  (type.class "java.lang.Object" (list)))

(def: (anonymous_init_method env)
  (-> (Environment Synthesis) (Type Method))
  (type.method [(list)
                (list.repeated (list.size env) $Object)
                type.void
                (list)]))

(def: (with_anonymous_init class env super_class inputsTI)
  (-> (Type Class) (Environment Synthesis) (Type Class) (List (Typed Inst)) Def)
  (let [store_capturedI (|> env
                            list.size
                            list.indices
                            (list\map (.function (_ register)
                                        (|>> (_.ALOAD 0)
                                             (_.ALOAD (++ register))
                                             (_.PUTFIELD class (///reference.foreign_name register) $Object))))
                            _.fuse)]
    (_def.method #$.Public $.noneM "<init>" (anonymous_init_method env)
                 (|>> (_.ALOAD 0)
                      ((_.fuse (list\map product.right inputsTI)))
                      (_.INVOKESPECIAL super_class "<init>" (type.method [(list) (list\map product.left inputsTI) type.void (list)]))
                      store_capturedI
                      _.RETURN))))

(def: (anonymous_instance generate archive class env)
  (-> Phase Archive (Type Class) (Environment Synthesis) (Operation Inst))
  (do {! phase.monad}
    [captureI+ (monad.map ! (generate archive) env)]
    (in (|>> (_.NEW class)
             _.DUP
             (_.fuse captureI+)
             (_.INVOKESPECIAL class "<init>" (anonymous_init_method env))))))

(def: (prepare_argument lux_register argumentT jvm_register)
  (-> Register (Type Value) Register [Register Inst])
  (case (type.primitive? argumentT)
    (#.Left argumentT)
    [(n.+ 1 jvm_register)
     (if (n.= lux_register jvm_register)
       (|>>)
       (|>> (_.ALOAD jvm_register)
            (_.ASTORE lux_register)))]
    
    (#.Right argumentT)
    (template.let [(wrap_primitive <shift> <load> <type>)
                   [[(n.+ <shift> jvm_register)
                     (|>> (<load> jvm_register)
                          (_.wrap <type>)
                          (_.ASTORE lux_register))]]]
      (`` (cond (~~ (template [<shift> <load> <type>]
                      [(\ type.equivalence = <type> argumentT)
                       (wrap_primitive <shift> <load> <type>)]

                      [1 _.ILOAD type.boolean]
                      [1 _.ILOAD type.byte]
                      [1 _.ILOAD type.short]
                      [1 _.ILOAD type.int]
                      [1 _.ILOAD type.char]
                      [1 _.FLOAD type.float]
                      [2 _.LLOAD type.long]))

                ... (\ type.equivalence = type.double argumentT)
                (wrap_primitive 2 _.DLOAD type.double))))))

(def: .public (prepare_arguments offset types)
  (-> Nat (List (Type Value)) Inst)
  (|> types
      list.enumeration
      (list\mix (function (_ [lux_register type] [jvm_register before])
                  (let [[jvm_register' after] (prepare_argument (n.+ offset lux_register) type jvm_register)]
                    [jvm_register' (|>> before after)]))
                (: [Register Inst] [offset (|>>)]))
      product.right))

(def: .public (returnI returnT)
  (-> (Type Return) Inst)
  (case (type.void? returnT)
    (#.Right returnT)
    _.RETURN

    (#.Left returnT)
    (case (type.primitive? returnT)
      (#.Left returnT)
      (case (type.class? returnT)
        (#.Some class_name)
        (|>> (_.CHECKCAST returnT)
             _.ARETURN)

        #.None
        _.ARETURN)
      
      (#.Right returnT)
      (template.let [(unwrap_primitive <return> <type>)
                     [(|>> (_.unwrap <type>)
                           <return>)]]
        (`` (cond (~~ (template [<return> <type>]
                        [(\ type.equivalence = <type> returnT)
                         (unwrap_primitive <return> <type>)]

                        [_.IRETURN type.boolean]
                        [_.IRETURN type.byte]
                        [_.IRETURN type.short]
                        [_.IRETURN type.int]
                        [_.IRETURN type.char]
                        [_.FRETURN type.float]
                        [_.LRETURN type.long]))

                  ... (\ type.equivalence = type.double returnT)
                  (unwrap_primitive _.DRETURN type.double)))))))

(def: class::anonymous
  Handler
  (..custom
   [($_ <>.and
        ..class
        (<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])
      (do {! phase.monad}
        [[context _] (generation.with_new_context archive (in []))
         .let [[module_id artifact_id] context
               anonymous_class_name (///.class_name context)
               class (type.class anonymous_class_name (list))
               total_environment (|> overriden_methods
                                     ... Get all the environments.
                                     (list\map product.left)
                                     ... Combine them.
                                     list\join
                                     ... Remove duplicates.
                                     (set.of_list synthesis.hash)
                                     set.list)
               global_mapping (|> total_environment
                                  ... Give them names as "foreign" variables.
                                  list.enumeration
                                  (list\map (function (_ [id capture])
                                              [capture (#variable.Foreign id)]))
                                  (dictionary.of_list synthesis.hash))
               normalized_methods (list\map (function (_ [environment
                                                          [ownerT name
                                                           strict_fp? annotations vars
                                                           self_name arguments returnT exceptionsT
                                                           body]])
                                              (let [local_mapping (|> environment
                                                                      list.enumeration
                                                                      (list\map (function (_ [foreign_id capture])
                                                                                  [(synthesis.variable/foreign foreign_id)
                                                                                   (|> global_mapping
                                                                                       (dictionary.value capture)
                                                                                       maybe.trusted)]))
                                                                      (dictionary.of_list synthesis.hash))]
                                                [ownerT name
                                                 strict_fp? annotations vars
                                                 self_name arguments returnT exceptionsT
                                                 (normalize_method_body local_mapping body)]))
                                            overriden_methods)]
         inputsTI (monad.map ! (generate_input generate archive) inputsTS)
         method_definitions (|> normalized_methods
                                (monad.map ! (function (_ [ownerT name
                                                           strict_fp? annotations varsT
                                                           self_name arguments returnT exceptionsT
                                                           bodyS])
                                               (do !
                                                 [bodyG (generation.with_context artifact_id
                                                          (generate archive bodyS))
                                                  .let [argumentsT (list\map product.right arguments)]]
                                                 (in (_def.method #$.Public
                                                                  (if strict_fp?
                                                                    ($_ $.++M $.finalM $.strictM)
                                                                    $.finalM)
                                                                  name
                                                                  (type.method [varsT argumentsT returnT exceptionsT])
                                                                  (|>> (prepare_arguments 1 argumentsT)
                                                                       bodyG
                                                                       (returnI returnT)))))))
                                (\ ! map _def.fuse))
         .let [directive [anonymous_class_name
                          (_def.class #$.V1_6 #$.Public $.finalC
                                      anonymous_class_name (list)
                                      super_class super_interfaces
                                      (|>> (///function.with_environment total_environment)
                                           (..with_anonymous_init class total_environment super_class inputsTI)
                                           method_definitions))]]
         _ (generation.execute! directive)
         _ (generation.save! artifact_id #.None directive)]
        (..anonymous_instance generate archive class total_environment)))]))

(def: class_bundle
  Bundle
  (<| (bundle.prefix "class")
      (|> (: Bundle bundle.empty)
          (bundle.install "anonymous" class::anonymous)
          )))

(def: .public bundle
  Bundle
  (<| (bundle.prefix "jvm")
      (|> ..conversion_bundle
          (dictionary.merged ..int_bundle)
          (dictionary.merged ..long_bundle)
          (dictionary.merged ..float_bundle)
          (dictionary.merged ..double_bundle)
          (dictionary.merged ..char_bundle)
          (dictionary.merged ..array_bundle)
          (dictionary.merged ..object_bundle)
          (dictionary.merged ..member_bundle)
          (dictionary.merged ..class_bundle)
          )))