path: root/stdlib/source/lux/tool/compiler/phase/extension/generation/jvm/host.lux

(.module:
  [lux (#- Type)
   [abstract
    ["." monad (#+ do)]]
   [control
    ["." try]
    ["." exception (#+ exception:)]
    ["<>" parser
     ["<t>" text]
     ["<s>" synthesis (#+ Parser)]]]
   [data
    ["." product]
    ["." maybe]
    ["." text ("#@." equivalence)]
    [number
     ["." i32]]
    [collection
     ["." list ("#@." monad)]
     ["." dictionary (#+ Dictionary)]
     ["." set]
     ["." row]]
    ["." format #_
     ["#" binary]]]
   [target
    [jvm
     ["." version]
     ["." modifier ("#@." monoid)]
     ["." method (#+ Method)]
     ["." class (#+ Class)]
     [constant
      [pool (#+ Resource)]]
     [encoding
      ["." name]]
     ["_" bytecode (#+ Label Bytecode) ("#@." monad)
      ["__" instruction (#+ Primitive-Array-Type)]]
     ["." type (#+ Type Typed Argument)
      ["." category (#+ Void Value' Value Return' Return Primitive Object Array Var Parameter)]
      ["." box]
      ["." reflection]
      ["." signature]
      ["." parser]]]]]
  [//
   [common (#+ custom)]
   [////
    [generation
     ["///" jvm
      [runtime (#+ Operation Bundle Handler)]
      ["#." reference]
      [function
       [field
        [variable
         ["." foreign]]]]
      ["//#" ///
       [generation
        [extension (#+ Nullary Unary Binary Trinary Variadic
                       nullary unary binary trinary variadic)]]
       [extension
        ["#." bundle]
        [analysis
         ["/" jvm]]]
       ["/#" //
        ["#." reference (#+ Variable)]
        [analysis (#+ Environment)]
        ["#." synthesis (#+ Synthesis Path %synthesis)]
        ["#." generation]]]]]]])

(template [<name> <0> <1>]
  [(def: <name>
     (Bytecode Any)
     ($_ _.compose
         <0>
         <1>))]

  [l2s _.l2i _.i2s]
  [l2b _.l2i _.i2b]
  [l2c _.l2i _.i2c]
  )

(template [<conversion> <name>]
  [(def: (<name> inputG)
     (Unary (Bytecode Any))
     (if (is? _.nop <conversion>)
       inputG
       ($_ _.compose
           inputG
           <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: bundle::conversion
  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> [xG yG])
     (Binary (Bytecode Any))
     ($_ _.compose
         xG
         yG
         <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: falseG (_.getstatic ..$Boolean "FALSE" ..$Boolean))
(def: trueG (_.getstatic ..$Boolean "TRUE" ..$Boolean))

(template [<name> <op>]
  [(def: (<name> [xG yG])
     (Binary (Bytecode Any))
     (do _.monad
       [@then _.new-label
        @end _.new-label]
       ($_ _.compose
           xG
           yG
           (<op> @then)
           falseG
           (_.goto @end)
           (_.set-label @then)
           trueG
           (_.set-label @end))))]

  [int::= _.if-icmpeq]
  [int::< _.if-icmplt]

  [char::= _.if-icmpeq]
  [char::< _.if-icmplt]
  )

(template [<name> <op> <reference>]
  [(def: (<name> [xG yG])
     (Binary (Bytecode Any))
     (do _.monad
       [@then _.new-label
        @end _.new-label]
       ($_ _.compose
           xG
           yG
           <op>
           (_.int (i32.i32 (.i64 <reference>)))
           (_.if-icmpeq @then)
           falseG
           (_.goto @end)
           (_.set-label @then)
           trueG
           (_.set-label @end))))]

  [long::= _.lcmp +0]
  [long::< _.lcmp -1]
  
  [float::= _.fcmpg +0]
  [float::< _.fcmpg -1]

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

(def: bundle::int
  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: bundle::long
  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: bundle::float
  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: bundle::double
  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: bundle::char
  Bundle
  (<| (/////bundle.prefix (reflection.reflection reflection.char))
      (|> (: Bundle /////bundle.empty)
          (/////bundle.install "=" (binary char::=))
          (/////bundle.install "<" (binary char::<))
          )))

(template [<name> <category> <parser>]
  [(def: #export <name>
     (Parser (Type <category>))
     (<t>.embed <parser> <s>.text))]

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

(exception: #export (not-an-object-array {arrayJT (Type Array)})
  (exception.report
   ["JVM Type" (|> arrayJT type.signature signature.signature)]))

(def: #export object-array
  (Parser (Type Object))
  (do <>.monad
    [arrayJT (<t>.embed parser.array <s>.text)]
    (case (parser.array? arrayJT)
      (#.Some elementJT)
      (case (parser.object? elementJT)
        (#.Some elementJT)
        (wrap elementJT)

        #.None
        (<>.fail (exception.construct ..not-an-object-array arrayJT)))
      
      #.None
      (undefined))))

(def: (primitive-array-length-handler jvm-primitive)
  (-> (Type Primitive) Handler)
  (..custom
   [<s>.any
    (function (_ extension-name generate arrayS)
      (do /////.monad
        [arrayG (generate arrayS)]
        (wrap ($_ _.compose
                  arrayG
                  (_.checkcast (type.array jvm-primitive))
                  _.arraylength))))]))

(def: array::length::object
  Handler
  (..custom
   [($_ <>.and ..object-array <s>.any)
    (function (_ extension-name generate [elementJT arrayS])
      (do /////.monad
        [arrayG (generate arrayS)]
        (wrap ($_ _.compose
                  arrayG
                  (_.checkcast (type.array elementJT))
                  _.arraylength))))]))

(def: (new-primitive-array-handler jvm-primitive)
  (-> Primitive-Array-Type Handler)
  (..custom
   [<s>.any
    (function (_ extension-name generate [lengthS])
      (do /////.monad
        [lengthG (generate lengthS)]
        (wrap ($_ _.compose
                  lengthG
                  (_.newarray jvm-primitive)))))]))

(def: array::new::object
  Handler
  (..custom
   [($_ <>.and ..object <s>.any)
    (function (_ extension-name generate [objectJT lengthS])
      (do /////.monad
        [lengthG (generate lengthS)]
        (wrap ($_ _.compose
                  lengthG
                  (_.anewarray objectJT)))))]))

(def: (read-primitive-array-handler jvm-primitive loadG)
  (-> (Type Primitive) (Bytecode Any) Handler)
  (..custom
   [($_ <>.and <s>.any <s>.any)
    (function (_ extension-name generate [idxS arrayS])
      (do /////.monad
        [arrayG (generate arrayS)
         idxG (generate idxS)]
        (wrap ($_ _.compose
                  arrayG
                  (_.checkcast (type.array jvm-primitive))
                  idxG
                  loadG))))]))

(def: array::read::object
  Handler
  (..custom
   [($_ <>.and ..object-array <s>.any <s>.any)
    (function (_ extension-name generate [elementJT idxS arrayS])
      (do /////.monad
        [arrayG (generate arrayS)
         idxG (generate idxS)]
        (wrap ($_ _.compose
                  arrayG
                  (_.checkcast (type.array elementJT))
                  idxG
                  _.aaload))))]))

(def: (write-primitive-array-handler jvm-primitive storeG)
  (-> (Type Primitive) (Bytecode Any) Handler)
  (..custom
   [($_ <>.and <s>.any <s>.any <s>.any)
    (function (_ extension-name generate [idxS valueS arrayS])
      (do /////.monad
        [arrayG (generate arrayS)
         idxG (generate idxS)
         valueG (generate valueS)]
        (wrap ($_ _.compose
                  arrayG
                  (_.checkcast (type.array jvm-primitive))
                  _.dup
                  idxG
                  valueG
                  storeG))))]))

(def: array::write::object
  Handler
  (..custom
   [($_ <>.and ..object-array <s>.any <s>.any <s>.any)
    (function (_ extension-name generate [elementJT idxS valueS arrayS])
      (do /////.monad
        [arrayG (generate arrayS)
         idxG (generate idxS)
         valueG (generate valueS)]
        (wrap ($_ _.compose
                  arrayG
                  (_.checkcast (type.array elementJT))
                  _.dup
                  idxG
                  valueG
                  _.aastore))))]))

(def: bundle::array
  Bundle
  (<| (/////bundle.prefix "array")
      (|> /////bundle.empty
          (dictionary.merge (<| (/////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.merge (<| (/////bundle.prefix "new")
                                (|> /////bundle.empty
                                    (/////bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler __.t-boolean))
                                    (/////bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler __.t-byte))
                                    (/////bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler __.t-short))
                                    (/////bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler __.t-int))
                                    (/////bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler __.t-long))
                                    (/////bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler __.t-float))
                                    (/////bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler __.t-double))
                                    (/////bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler __.t-char))
                                    (/////bundle.install "object" array::new::object))))
          (dictionary.merge (<| (/////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.merge (<| (/////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 (Bytecode Any))
  _.aconst-null)

(def: (object::null? objectG)
  (Unary (Bytecode Any))
  (do _.monad
    [@then _.new-label
     @end _.new-label]
    ($_ _.compose
        objectG
        (_.ifnull @then)
        ..falseG
        (_.goto @end)
        (_.set-label @then)
        ..trueG
        (_.set-label @end))))

(def: (object::synchronized [monitorG exprG])
  (Binary (Bytecode Any))
  ($_ _.compose
      monitorG
      _.dup
      _.monitorenter
      exprG
      _.swap
      _.monitorexit))

(def: (object::throw exceptionG)
  (Unary (Bytecode Any))
  ($_ _.compose
      exceptionG
      _.athrow))

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

(def: object::class
  Handler
  (..custom
   [<s>.text
    (function (_ extension-name generate [class])
      (do /////.monad
        []
        (wrap ($_ _.compose
                  (_.string class)
                  (_.invokestatic ..$Class "forName" (type.method [(list ..$String) ..$Class (list)]))))))]))

(def: object::instance?
  Handler
  (..custom
   [($_ <>.and <s>.text <s>.any)
    (function (_ extension-name generate [class objectS])
      (do /////.monad
        [objectG (generate objectS)]
        (wrap ($_ _.compose
                  objectG
                  (_.instanceof (type.class class (list)))
                  (_.invokestatic ..$Boolean "valueOf" (type.method [(list type.boolean) ..$Boolean (list)]))))))]))

(def: reflection
  (All [category]
    (-> (Type (<| Return' Value' category)) Text))
  (|>> type.reflection reflection.reflection))

(def: object::cast
  Handler
  (..custom
   [($_ <>.and <s>.text <s>.text <s>.any)
    (function (_ extension-name generate [from to valueS])
      (do /////.monad
        [valueG (generate valueS)]
        (wrap (`` (cond (~~ (template [<object> <type> <unwrap>]
                              [(and (text@= (..reflection <type>)
                                            from)
                                    (text@= <object>
                                            to))
                               (let [$<object> (type.class <object> (list))]
                                 ($_ _.compose
                                     valueG
                                     (_.invokestatic $<object> "valueOf" (type.method [(list <type>) $<object> (list)]))))

                               (and (text@= <object>
                                            from)
                                    (text@= (..reflection <type>)
                                            to))
                               (let [$<object> (type.class <object> (list))]
                                 ($_ _.compose
                                     valueG
                                     (_.checkcast $<object>)
                                     (_.invokevirtual $<object> <unwrap> (type.method [(list) <type> (list)]))))]
                              
                              [box.boolean type.boolean "booleanValue"]
                              [box.byte    type.byte    "byteValue"]
                              [box.short   type.short   "shortValue"]
                              [box.int     type.int     "intValue"]
                              [box.long    type.long    "longValue"]
                              [box.float   type.float   "floatValue"]
                              [box.double  type.double  "doubleValue"]
                              [box.char    type.char    "charValue"]))
                        ## else
                        valueG)))))]))

(def: bundle::object
  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.from-list text.hash)))

(def: get::static
  Handler
  (..custom
   [($_ <>.and <s>.text <s>.text <s>.text)
    (function (_ extension-name generate [class field unboxed])
      (do /////.monad
        [#let [$class (type.class class (list))]]
        (case (dictionary.get unboxed ..primitives)
          (#.Some primitive)
          (wrap (_.getstatic $class field primitive))
          
          #.None
          (wrap (_.getstatic $class field (type.class unboxed (list)))))))]))

(def: unitG (_.string //////synthesis.unit))

(def: put::static
  Handler
  (..custom
   [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
    (function (_ extension-name generate [class field unboxed valueS])
      (do /////.monad
        [valueG (generate valueS)
         #let [$class (type.class class (list))]]
        (case (dictionary.get unboxed ..primitives)
          (#.Some primitive)
          (wrap ($_ _.compose
                    valueG
                    (_.putstatic $class field primitive)
                    ..unitG))
          
          #.None
          (wrap ($_ _.compose
                    valueG
                    (_.checkcast $class)
                    (_.putstatic $class field $class)
                    ..unitG)))))]))

(def: get::virtual
  Handler
  (..custom
   [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
    (function (_ extension-name generate [class field unboxed objectS])
      (do /////.monad
        [objectG (generate objectS)
         #let [$class (type.class class (list))
               getG (case (dictionary.get unboxed ..primitives)
                      (#.Some primitive)
                      (_.getfield $class field primitive)
                      
                      #.None
                      (_.getfield $class field (type.class unboxed (list))))]]
        (wrap ($_ _.compose
                  objectG
                  (_.checkcast $class)
                  getG))))]))

(def: put::virtual
  Handler
  (..custom
   [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any)
    (function (_ extension-name generate [class field unboxed valueS objectS])
      (do /////.monad
        [valueG (generate valueS)
         objectG (generate objectS)
         #let [$class (type.class class (list))
               putG (case (dictionary.get unboxed ..primitives)
                      (#.Some primitive)
                      (_.putfield $class field primitive)
                      
                      #.None
                      (let [$unboxed (type.class unboxed (list))]
                        ($_ _.compose
                            (_.checkcast $unboxed)
                            (_.putfield $class field $unboxed))))]]
        (wrap ($_ _.compose
                  objectG
                  (_.checkcast $class)
                  _.dup
                  valueG
                  putG))))]))

(type: Input (Typed Synthesis))

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

(def: (generate-input generate [valueT valueS])
  (-> (-> Synthesis (Operation (Bytecode Any))) Input
      (Operation (Typed (Bytecode Any))))
  (do /////.monad
    [valueG (generate valueS)]
    (case (type.primitive? valueT)
      (#.Right valueT)
      (wrap [valueT valueG])
      
      (#.Left valueT)
      (wrap [valueT ($_ _.compose
                        valueG
                        (_.checkcast valueT))]))))

(def: (prepare-output outputT)
  (-> (Type Return) (Bytecode Any))
  (case (type.void? outputT)
    (#.Right outputT)
    ..unitG
    
    (#.Left outputT)
    (:: _.monad wrap [])))

(def: invoke::static
  Handler
  (..custom
   [($_ <>.and ..class <s>.text ..return (<>.some ..input))
    (function (_ extension-name generate [class method outputT inputsTS])
      (do /////.monad
        [inputsTG (monad.map @ (generate-input generate) inputsTS)]
        (wrap ($_ _.compose
                  (monad.map _.monad product.right inputsTG)
                  (_.invokestatic class method (type.method [(list@map product.left inputsTG) outputT (list)]))
                  (prepare-output outputT)))))]))

(template [<name> <invoke>]
  [(def: <name>
     Handler
     (..custom
      [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input))
       (function (_ extension-name generate [class method outputT objectS inputsTS])
         (do /////.monad
           [objectG (generate objectS)
            inputsTG (monad.map @ (generate-input generate) inputsTS)]
           (wrap ($_ _.compose
                     objectG
                     (_.checkcast class)
                     (monad.map _.monad product.right inputsTG)
                     (<invoke> class method (type.method [(list@map product.left inputsTG) 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 [class inputsTS])
      (do /////.monad
        [inputsTG (monad.map @ (generate-input generate) inputsTS)]
        (wrap ($_ _.compose
                  (_.new class)
                  _.dup
                  (monad.map _.monad product.right inputsTG)
                  (_.invokespecial class "<init>" (type.method [(list@map product.left inputsTG) type.void (list)]))))))]))

(def: bundle::member
  Bundle
  (<| (/////bundle.prefix "member")
      (|> (: Bundle /////bundle.empty)
          (dictionary.merge (<| (/////bundle.prefix "get")
                                (|> (: Bundle /////bundle.empty)
                                    (/////bundle.install "static" get::static)
                                    (/////bundle.install "virtual" get::virtual))))
          (dictionary.merge (<| (/////bundle.prefix "put")
                                (|> (: Bundle /////bundle.empty)
                                    (/////bundle.install "static" put::static)
                                    (/////bundle.install "virtual" put::virtual))))
          (dictionary.merge (<| (/////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))
  (<s>.tuple (<>.and <s>.text <s>.any)))

(def: annotation
  (Parser (/.Annotation Synthesis))
  (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter))))

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

(def: overriden-method-definition
  (Parser [Environment (/.Overriden-Method Synthesis)])
  (<s>.tuple (do <>.monad
               [_ (<s>.text! /.overriden-tag)
                ownerT ..class
                name <s>.text
                strict-fp? <s>.bit
                annotations (<s>.tuple (<>.some ..annotation))
                vars (<s>.tuple (<>.some ..var))
                self-name <s>.text
                arguments (<s>.tuple (<>.some ..argument))
                returnT ..return
                exceptionsT (<s>.tuple (<>.some ..class))
                [environment body] (<s>.function 1
                                     (<s>.tuple <s>.any))]
               (wrap [environment
                      [ownerT name
                       strict-fp? annotations vars
                       self-name arguments returnT exceptionsT
                       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.Test]
       [#//////synthesis.Bind]
       [#//////synthesis.Access]))))

(def: (normalize-method-body mapping)
  (-> (Dictionary Variable 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.get var)
          (maybe.default 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.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 [(|> environment (list@map (function (_ local)
                                                                         (|> mapping
                                                                             (dictionary.get local)
                                                                             (maybe.default local)))))
                                             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 (Type category.Method))
  (type.method [(list.repeat (list.size env) ..$Object)
                type.void
                (list)]))

(def: (with-anonymous-init class env super-class inputsTG)
  (-> (Type category.Class) Environment (Type category.Class) (List (Typed (Bytecode Any))) (Resource Method))
  (let [store-capturedG (|> env
                            list.size
                            list.indices
                            (monad.map _.monad (.function (_ register)
                                                 ($_ _.compose
                                                     (_.aload 0)
                                                     (_.aload (inc register))
                                                     (_.putfield class (///reference.foreign-name register) $Object)))))]
    (method.method method.public "<init>" (anonymous-init-method env)
                   (list)
                   (#.Some ($_ _.compose
                               (_.aload 0)
                               (monad.map _.monad product.right inputsTG)
                               (_.invokespecial super-class "<init>" (type.method [(list@map product.left inputsTG) type.void (list)]))
                               store-capturedG
                               _.return)))))

(def: (anonymous-instance class env)
  (-> (Type category.Class) Environment (Operation (Bytecode Any)))
  (do /////.monad
    [captureG+ (monad.map @ ///reference.variable env)]
    (wrap ($_ _.compose
              (_.new class)
              _.dup
              (monad.seq _.monad captureG+)
              (_.invokespecial class "<init>" (anonymous-init-method env))))))

(def: (returnG returnT)
  (-> (Type Return) (Bytecode Any))
  (case (type.void? returnT)
    (#.Right returnT)
    _.return

    (#.Left returnT)
    (case (type.primitive? returnT)
      (#.Left returnT)
      ($_ _.compose
          (_.checkcast returnT)
          _.areturn)
      
      (#.Right returnT)
      (cond (or (:: type.equivalence = type.boolean returnT)
                (:: type.equivalence = type.byte returnT)
                (:: type.equivalence = type.short returnT)
                (:: type.equivalence = type.int returnT)
                (:: type.equivalence = type.char returnT))
            _.ireturn

            (:: type.equivalence = type.long returnT)
            _.lreturn

            (:: type.equivalence = type.float returnT)
            _.freturn

            ## (:: type.equivalence = type.double returnT)
            _.dreturn))))

(def: class::anonymous
  Handler
  (..custom
   [($_ <>.and
        <s>.text
        ..class
        (<s>.tuple (<>.some ..class))
        (<s>.tuple (<>.some ..input))
        (<s>.tuple (<>.some ..overriden-method-definition)))
    (function (_ extension-name generate [class-name
                                          super-class super-interfaces
                                          inputsTS
                                          overriden-methods])
      (do /////.monad
        [#let [class (type.class class-name (list))
               total-environment (|> overriden-methods
                                     ## Get all the environments.
                                     (list@map product.left)
                                     ## Combine them.
                                     list@join
                                     ## Remove duplicates.
                                     (set.from-list //////reference.hash)
                                     set.to-list)
               global-mapping (|> total-environment
                                  ## Give them names as "foreign" variables.
                                  list.enumerate
                                  (list@map (function (_ [id capture])
                                              [capture (#//////reference.Foreign id)]))
                                  (dictionary.from-list //////reference.hash))
               normalized-methods (list@map (function (_ [environment
                                                          [ownerT name
                                                           strict-fp? annotations vars
                                                           self-name arguments returnT exceptionsT
                                                           body]])
                                              (let [local-mapping (|> environment
                                                                      list.enumerate
                                                                      (list@map (function (_ [foreign-id capture])
                                                                                  [(#//////reference.Foreign foreign-id)
                                                                                   (|> global-mapping
                                                                                       (dictionary.get capture)
                                                                                       maybe.assume)]))
                                                                      (dictionary.from-list //////reference.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) inputsTS)
         method-definitions (monad.map @ (function (_ [ownerT name
                                                       strict-fp? annotations vars
                                                       self-name arguments returnT exceptionsT
                                                       bodyS])
                                           (do @
                                             [bodyG (//////generation.with-specific-context class-name
                                                      (generate bodyS))]
                                             (wrap (method.method ($_ modifier@compose
                                                                      method.public
                                                                      method.final
                                                                      (if strict-fp?
                                                                        method.strict
                                                                        modifier@identity))
                                                                  name
                                                                  (type.method [(list@map product.right arguments)
                                                                                returnT
                                                                                exceptionsT])
                                                                  (list)
                                                                  (#.Some ($_ _.compose
                                                                              bodyG
                                                                              (returnG returnT)))))))
                                       normalized-methods)
         bytecode (<| (:: @ map (format.run class.writer))
                      /////.lift
                      (class.class version.v6_0 ($_ modifier@compose class.public class.final)
                                   (name.internal class-name)
                                   (name.internal (..reflection super-class))
                                   (list@map (|>> ..reflection name.internal) super-interfaces)
                                   (foreign.variables total-environment)
                                   (list& (..with-anonymous-init class total-environment super-class inputsTI)
                                          method-definitions)
                                   (row.row)))
         _ (//////generation.save! true ["" class-name] [class-name bytecode])]
        (anonymous-instance class total-environment)))]))

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

(def: #export bundle
  Bundle
  (<| (/////bundle.prefix "jvm")
      (|> ..bundle::conversion
          (dictionary.merge ..bundle::int)
          (dictionary.merge ..bundle::long)
          (dictionary.merge ..bundle::float)
          (dictionary.merge ..bundle::double)
          (dictionary.merge ..bundle::char)
          (dictionary.merge ..bundle::array)
          (dictionary.merge ..bundle::object)
          (dictionary.merge ..bundle::member)
          (dictionary.merge ..bundle::class)
          )))