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

(.using
 [library
  [lux {"-" Type Label Primitive int char type}
   [ffi {"+" import:}]
   [abstract
    ["[0]" monad {"+" do}]]
   [control
    ["[0]" maybe ("[1]#[0]" functor)]
    ["[0]" exception {"+" exception:}]
    ["[0]" function]
    ["<>" parser ("[1]#[0]" monad)
     ["<[0]>" text]
     ["<[0]>" synthesis {"+" Parser}]]]
   [data
    ["[0]" product]
    ["[0]" text ("[1]#[0]" equivalence)
     ["%" format {"+" format}]]
    [collection
     ["[0]" list ("[1]#[0]" monoid mix monad)]
     ["[0]" dictionary {"+" Dictionary}]
     ["[0]" set {"+" Set}]]]
   [macro
    ["^" pattern]
    ["[0]" template]]
   [math
    [number
     ["n" nat]]]
   [target
    [jvm
     ["[0]" type {"+" Type Typed Argument}
      ["[0]" category {"+" Void Value Return Primitive Object Class Array Var Parameter Method}]
      ["[0]" box]
      ["[0]" reflection]
      ["[0]" signature]
      ["[0]" descriptor]
      ["[0]" parser]]]]
   [tool
    [compiler
     ["[0]" phase ("[1]#[0]" monad)]
     [reference {"+" }
      ["[0]" variable {"+" Variable Register}]]
     [meta
      [archive {"+" Archive}
       ["[0]" unit]]
      ["[0]" cache "_"
       ["[1]" artifact]]]
     [language
      [lux
       [analysis {"+" Environment}]
       ["[0]" synthesis {"+" Synthesis Path %synthesis}]
       ["[0]" generation]
       [phase
        [generation
         [extension {"+" Nullary Unary Binary
                     nullary unary binary}]]
        [analysis
         ["[0]A" reference]]
        ["[0]" extension
         ["[0]" bundle]
         [analysis
          ["/" jvm]]]]]]]]]]
 [luxc
  [lang
   [host
    ["$" jvm {"+" Label Inst Def Handler Bundle Operation Phase}
     ["_" inst]
     ["_[0]" def]]]]]
 ["[0]" // "_"
  [common {"+" custom}]
  ["/[1]" //
   ["[1][0]" reference]
   ["[1][0]" 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")
      (|> (is 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 subjectI])
     (Binary Inst)
     (|>> subjectI
          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))
      (|> (is 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))
      (|> (is 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))
      (|> (is 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))
      (|> (is 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))
      (|> (is 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
      (pattern (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
      (pattern (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
      (pattern (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
    (pattern (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
    (pattern (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")
      (|> (is 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.each ! (generate_input generate archive) inputsTS)]
        (in (|>> (_.fuse (list#each product.right inputsTI))
                 (_.INVOKESTATIC class method (type.method [(list) (list#each 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.each ! (generate_input generate archive) inputsTS)]
           (in (|>> objectI
                    (_.CHECKCAST class)
                    (_.fuse (list#each product.right inputsTI))
                    (<invoke> class method
                              (type.method [(list)
                                            (list#each 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.each ! (generate_input generate archive) inputsTS)]
        (in (|>> (_.NEW class)
                 _.DUP
                 (_.fuse (list#each product.right inputsTI))
                 (_.INVOKESPECIAL class "<init>" (type.method [(list) (list#each product.left inputsTI) type.void (list)]))))))]))

(def: member_bundle
  Bundle
  (<| (bundle.prefix "member")
      (|> (is Bundle bundle.empty)
          (dictionary.merged (<| (bundle.prefix "get")
                                 (|> (is Bundle bundle.empty)
                                     (bundle.install "static" get::static)
                                     (bundle.install "virtual" get::virtual))))
          (dictionary.merged (<| (bundle.prefix "put")
                                 (|> (is Bundle bundle.empty)
                                     (bundle.install "static" put::static)
                                     (bundle.install "virtual" put::virtual))))
          (dictionary.merged (<| (bundle.prefix "invoke")
                                 (|> (is 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 (again [path (is synthesis.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}
        (again next)
        
        {synthesis.#Then hidden}
        hidden))

    _
    body))

(def: overriden_method_definition
  (Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)])
  (<synthesis>.tuple
   (do <>.monad
     [_ (<synthesis>.this_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 (again path)
    (case path
      (pattern (synthesis.path/then bodyS))
      (synthesis.path/then (normalize bodyS))

      (^.template [<tag>]
        [(pattern {<tag> leftP rightP})
         {<tag> (again leftP) (again rightP)}])
      ([synthesis.#Alt]
       [synthesis.#Seq])

      (^.template [<tag>]
        [(pattern {<tag> _})
         path])
      ([synthesis.#Pop]
       [synthesis.#Bind]
       [synthesis.#Access])

      {synthesis.#Bit_Fork when then else}
      {synthesis.#Bit_Fork when (again then) (maybe#each again else)}

      (^.template [<tag>]
        [{<tag> [[test then] elses]}
         {<tag> [[test (again then)]
                 (list#each (function (_ [else_test else_then])
                              [else_test (again else_then)])
                            elses)]}])
      ([synthesis.#I64_Fork]
       [synthesis.#F64_Fork]
       [synthesis.#Text_Fork])
      )))

(type: Mapping
  (Dictionary Synthesis Variable))

(def: (local_mapping global_mapping)
  (-> Mapping (Environment Synthesis) Mapping)
  (|>> list.enumeration
       (list#each (function (_ [foreign_id capture])
                    [(synthesis.variable/foreign foreign_id)
                     (|> global_mapping
                         (dictionary.value capture)
                         maybe.trusted)]))
       (dictionary.of_list synthesis.hash)))

(def: (init_mapping global_mapping)
  (-> Mapping (Environment Synthesis) Mapping)
  (|>> list.enumeration
       (list#each (function (_ [id capture])
                    [(synthesis.variable/foreign id)
                     {variable.#Local (++ id)}]))
       (dictionary.of_list synthesis.hash)))

(def: (normalize_method_body mapping)
  (-> Mapping Synthesis Synthesis)
  (function (again body)
    (case body
      (^.template [<tag>]
        [(pattern <tag>)
         body])
      ([{synthesis.#Primitive _}]
       [(synthesis.constant _)])

      (pattern (synthesis.variant [lefts right? sub]))
      (synthesis.variant [lefts right? (again sub)])

      (pattern (synthesis.tuple members))
      (synthesis.tuple (list#each again members))

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

      (pattern (synthesis.branch/case [inputS pathS]))
      (synthesis.branch/case [(again inputS) (normalize_path again pathS)])

      (pattern (synthesis.branch/exec [this that]))
      (synthesis.branch/exec [(again this) (again that)])

      (pattern (synthesis.branch/let [inputS register outputS]))
      (synthesis.branch/let [(again inputS) register (again outputS)])

      (pattern (synthesis.branch/if [testS thenS elseS]))
      (synthesis.branch/if [(again testS) (again thenS) (again elseS)])

      (pattern (synthesis.branch/get [path recordS]))
      (synthesis.branch/get [path (again recordS)])

      (pattern (synthesis.loop/scope [offset initsS+ bodyS]))
      (synthesis.loop/scope [offset (list#each again initsS+) (again bodyS)])

      (pattern (synthesis.loop/again updatesS+))
      (synthesis.loop/again (list#each again updatesS+))

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

                                                      _
                                                      captured))
                                                  environment)
                                       arity
                                       bodyS])

      (pattern (synthesis.function/apply [functionS inputsS+]))
      (synthesis.function/apply [(again functionS) (list#each again inputsS+)])

      {synthesis.#Extension [name inputsS+]}
      {synthesis.#Extension [name (list#each again inputsS+)]})))

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

(def: (anonymous_init_method env inputsTI)
  (-> (Environment Synthesis) (List (Typed Inst)) (Type Method))
  (type.method [(list)
                (list.repeated (n.+ (list.size inputsTI) (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 [inputs_offset (list.size inputsTI)
        inputs! (|> inputsTI
                    list.enumeration
                    (list#each (function (_ [register [type term]])
                                 (let [then! (case (type.primitive? type)
                                               {.#Right type}
                                               (_.unwrap type)
                                               
                                               {.#Left type}
                                               (_.CHECKCAST type))]
                                   (|>> (_.ALOAD (++ register))
                                        then!))))
                    _.fuse)
        store_capturedI (|> env
                            list.size
                            list.indices
                            (list#each (.function (_ register)
                                         (|>> (_.ALOAD 0)
                                              (_.ALOAD (n.+ inputs_offset (++ register)))
                                              (_.PUTFIELD class (///reference.foreign_name register) $Object))))
                            _.fuse)]
    (_def.method {$.#Public} $.noneM "<init>" (anonymous_init_method env inputsTI)
                 (|>> (_.ALOAD 0)
                      inputs!
                      (_.INVOKESPECIAL super_class "<init>" (type.method [(list) (list#each product.left inputsTI) type.void (list)]))
                      store_capturedI
                      _.RETURN))))

(def: (anonymous_instance generate archive class env inputsTI)
  (-> Phase Archive (Type Class) (Environment Synthesis) (List (Typed Inst)) (Operation Inst))
  (do [! phase.monad]
    [captureI+ (monad.each ! (generate archive) env)]
    (in (|>> (_.NEW class)
             _.DUP
             ((_.fuse (list#each product.right inputsTI)))
             ((_.fuse captureI+))
             (_.INVOKESPECIAL class "<init>" (anonymous_init_method env inputsTI))))))

(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)]))
                (is [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: (method_dependencies archive method)
  (-> Archive (/.Overriden_Method Synthesis) (Operation (Set unit.ID)))
  (let [[_super _name _strict_fp? _annotations
         _t_vars _this _arguments _return _exceptions
         bodyS] method]
    (cache.dependencies archive bodyS)))

(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]
        [all_input_dependencies (monad.each ! (|>> product.right (cache.dependencies archive)) inputsTS)
         all_closure_dependencies (|> overriden_methods
                                      (list#each product.left)
                                      list.together
                                      (monad.each ! (cache.dependencies archive)))
         all_method_dependencies (monad.each ! (|>> product.right (method_dependencies archive)) overriden_methods)
         .let [all_dependencies (cache.all ($_ list#composite
                                               all_input_dependencies
                                               all_closure_dependencies
                                               all_method_dependencies))]
         [context _] (generation.with_new_context
                       archive
                       all_dependencies
                       (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#each product.left)
                                     ... Combine them.
                                     list#conjoint
                                     ... Remove duplicates.
                                     (set.of_list synthesis.hash)
                                     set.list)
               global_mapping (|> total_environment
                                  ... Give them names as "foreign" variables.
                                  list.enumeration
                                  (list#each (function (_ [id capture])
                                               [capture {variable.#Foreign id}]))
                                  (dictionary.of_list synthesis.hash))
               normalized_methods (list#each (function (_ [environment
                                                           [ownerT name
                                                            strict_fp? annotations vars
                                                            self_name arguments returnT exceptionsT
                                                            body]])
                                               [ownerT name
                                                strict_fp? annotations vars
                                                self_name arguments returnT exceptionsT
                                                (normalize_method_body (..local_mapping global_mapping environment)
                                                                       body)])
                                             overriden_methods)
               inputsTS (let [mapping (..init_mapping global_mapping total_environment)]
                          (list#each (function (_ [type term])
                                       [type (normalize_method_body mapping term)])
                                     inputsTS))]
         inputsTI (generation.with_context artifact_id
                    (monad.each ! (generate_input generate archive) inputsTS))
         method_definitions (|> normalized_methods
                                (monad.each ! (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#each 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)))))))
                                (# ! each _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 inputsTI)))]))

(def: class_bundle
  Bundle
  (<| (bundle.prefix "class")
      (|> (is 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)
          )))