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

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

  [var Var parser.var]
  [class 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 (<text>.embed parser.array <synthesis>.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))))

(template [<name> <inst>]
  [(def: <name>
     Inst
     <inst>)]

  [L2S (|>> _.L2I _.I2S)]
  [L2B (|>> _.L2I _.I2B)]
  [L2C (|>> _.L2I _.I2C)]
  )

(template [<conversion> <name>]
  [(def: (<name> inputI)
     (Unary Inst)
     (if (is? _.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.prefix "conversion")
      (|> (: Bundle bundle.empty)
          (bundle.install "double-to-float" (unary conversion::double_to_float))
          (bundle.install "double-to-int" (unary conversion::double_to_int))
          (bundle.install "double-to-long" (unary conversion::double_to_long))
          (bundle.install "float-to-double" (unary conversion::float_to_double))
          (bundle.install "float-to-int" (unary conversion::float_to_int))
          (bundle.install "float-to-long" (unary conversion::float_to_long))
          (bundle.install "int-to-byte" (unary conversion::int_to_byte))
          (bundle.install "int-to-char" (unary conversion::int_to_char))
          (bundle.install "int-to-double" (unary conversion::int_to_double))
          (bundle.install "int-to-float" (unary conversion::int_to_float))
          (bundle.install "int-to-long" (unary conversion::int_to_long))
          (bundle.install "int-to-short" (unary conversion::int_to_short))
          (bundle.install "long-to-double" (unary conversion::long_to_double))
          (bundle.install "long-to-float" (unary conversion::long_to_float))
          (bundle.install "long-to-int" (unary conversion::long_to_int))
          (bundle.install "long-to-short" (unary conversion::long_to_short))
          (bundle.install "long-to-byte" (unary conversion::long_to_byte))
          (bundle.install "long-to-char" (unary conversion::long_to_char))
          (bundle.install "char-to-byte" (unary conversion::char_to_byte))
          (bundle.install "char-to-short" (unary conversion::char_to_short))
          (bundle.install "char-to-int" (unary conversion::char_to_int))
          (bundle.install "char-to-long" (unary conversion::char_to_long))
          (bundle.install "byte-to-long" (unary conversion::byte_to_long))
          (bundle.install "short-to-long" (unary conversion::short_to_long))
          )))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      _
      (phase.throw 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)]
        (wrap (|>> lengthI
                   (_.ANEWARRAY objectJT)))))]))

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

      _
      (phase.throw 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)]
        (wrap (|>> arrayI
                   (_.CHECKCAST (type.array elementJT))
                   idxI
                   _.AALOAD))))]))

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

      _
      (phase.throw 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)]
        (wrap (|>> arrayI
                   (_.CHECKCAST (type.array elementJT))
                   _.DUP
                   idxI
                   valueI
                   _.AASTORE))))]))

(def: 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 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.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 Inst)
  _.NULL)

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

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

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

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

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

    _
    (phase.throw 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)]
        (wrap (|>> objectI
                   (_.INSTANCEOF (type.class class (list)))
                   (_.wrap type.boolean)))))]))

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

                       (and (text@= <object>
                                    from)
                            (text@= (reflection.reflection (type.reflection <type>))
                                    to))
                       (wrap (|>> valueI (_.unwrap <type>)))]
                      
                      [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
                (wrap valueI))))

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

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

(def: primitives
  (Dictionary Text (Type Primitive))
  (|> (list [(reflection.reflection reflection.boolean) type.boolean]
            [(reflection.reflection reflection.byte) type.byte]
            [(reflection.reflection reflection.short) type.short]
            [(reflection.reflection reflection.int) type.int]
            [(reflection.reflection reflection.long) type.long]
            [(reflection.reflection reflection.float) type.float]
            [(reflection.reflection reflection.double) type.double]
            [(reflection.reflection reflection.char) type.char])
      (dictionary.from_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.get unboxed ..primitives)
          (#.Some primitive)
          (wrap (_.GETSTATIC (type.class class (list)) field primitive))
          
          #.None
          (wrap (_.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.get unboxed ..primitives)
          (#.Some primitive)
          (wrap (|>> valueI
                     (_.PUTSTATIC $class field primitive)
                     (_.string synthesis.unit)))
          
          #.None
          (wrap (|>> 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.get unboxed ..primitives)
                      (#.Some primitive)
                      (_.GETFIELD $class field primitive)
                      
                      #.None
                      (_.GETFIELD $class field (type.class unboxed (list))))]]
        (wrap (|>> 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.get unboxed ..primitives)
                      (#.Some primitive)
                      (_.PUTFIELD $class field primitive)
                      
                      #.None
                      (let [$unboxed (type.class unboxed (list))]
                        (|>> (_.CHECKCAST $unboxed)
                             (_.PUTFIELD $class field $unboxed))))]]
        (wrap (|>> 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)
      (wrap [valueT valueI])
      
      (#.Left valueT)
      (wrap [valueT (|>> valueI
                         (_.CHECKCAST valueT))]))))

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

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

(def: invoke::static
  Handler
  (..custom
   [($_ <>.and ..class <synthesis>.text ..return (<>.some ..input))
    (function (_ extension_name generate archive [class method outputT inputsTS])
      (do {@ phase.monad}
        [inputsTI (monad.map @ (generate_input generate archive) inputsTS)]
        (wrap (|>> (_.fuse (list@map product.right inputsTI))
                   (_.INVOKESTATIC class method (type.method [(list@map product.left inputsTI) outputT (list)]))
                   (prepare_output outputT)))))]))

(template [<name> <invoke>]
  [(def: <name>
     Handler
     (..custom
      [($_ <>.and ..class <synthesis>.text ..return <synthesis>.any (<>.some ..input))
       (function (_ extension_name generate archive [class method outputT objectS inputsTS])
         (do {@ phase.monad}
           [objectI (generate archive objectS)
            inputsTI (monad.map @ (generate_input generate archive) inputsTS)]
           (wrap (|>> objectI
                      (_.CHECKCAST class)
                      (_.fuse (list@map product.right inputsTI))
                      (<invoke> class method
                                (type.method [(list@map product.left inputsTI)
                                              outputT
                                              (list)]))
                      (prepare_output outputT)))))]))]

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

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

(def: 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))
  (<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: overriden_method_definition
  (Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)])
  (<synthesis>.tuple
   (do <>.monad
     [_ (<synthesis>.text! /.overriden_tag)
      ownerT ..class
      name <synthesis>.text
      strict_fp? <synthesis>.bit
      annotations (<synthesis>.tuple (<>.some ..annotation))
      vars (<synthesis>.tuple (<>.some ..var))
      self_name <synthesis>.text
      arguments (<synthesis>.tuple (<>.some ..argument))
      returnT ..return
      exceptionsT (<synthesis>.tuple (<>.some ..class))
      [environment _ _ body] (<synthesis>.function 1
                               (<synthesis>.loop (<>.exactly 0 <synthesis>.any)
                                 (<synthesis>.tuple <synthesis>.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.Bind]
       [#synthesis.Access])

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

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

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

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

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

      (^ (synthesis.variable var))
      (|> mapping
          (dictionary.get body)
          (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.branch/get [path recordS]))
      (synthesis.branch/get [path (recur recordS)])

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

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

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

                                                     _
                                                     captured))
                                                 environment)
                                       arity
                                       bodyS])

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

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

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

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

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

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

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

    (#.Left returnT)
    (case (type.primitive? returnT)
      (#.Left returnT)
      (|>> (_.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
        ..class
        (<synthesis>.tuple (<>.some ..class))
        (<synthesis>.tuple (<>.some ..input))
        (<synthesis>.tuple (<>.some ..overriden_method_definition)))
    (function (_ extension_name generate archive [super_class super_interfaces
                                                  inputsTS
                                                  overriden_methods])
      (do {@ phase.monad}
        [[context _] (generation.with_new_context archive (wrap []))
         #let [[module_id artifact_id] context
               anonymous_class_name (///.class_name context)
               class (type.class anonymous_class_name (list))
               total_environment (|> overriden_methods
                                     ## Get all the environments.
                                     (list@map product.left)
                                     ## Combine them.
                                     list@join
                                     ## Remove duplicates.
                                     (set.from_list synthesis.hash)
                                     set.to_list)
               global_mapping (|> total_environment
                                  ## Give them names as "foreign" variables.
                                  list.enumeration
                                  (list@map (function (_ [id capture])
                                              [capture (#variable.Foreign id)]))
                                  (dictionary.from_list synthesis.hash))
               normalized_methods (list@map (function (_ [environment
                                                          [ownerT name
                                                           strict_fp? annotations vars
                                                           self_name arguments returnT exceptionsT
                                                           body]])
                                              (let [local_mapping (|> environment
                                                                      list.enumeration
                                                                      (list@map (function (_ [foreign_id capture])
                                                                                  [(synthesis.variable/foreign foreign_id)
                                                                                   (|> global_mapping
                                                                                       (dictionary.get capture)
                                                                                       maybe.assume)]))
                                                                      (dictionary.from_list synthesis.hash))]
                                                [ownerT name
                                                 strict_fp? annotations vars
                                                 self_name arguments returnT exceptionsT
                                                 (normalize_method_body local_mapping body)]))
                                            overriden_methods)]
         inputsTI (monad.map @ (generate_input generate archive) inputsTS)
         method_definitions (|> normalized_methods
                                (monad.map @ (function (_ [ownerT name
                                                           strict_fp? annotations vars
                                                           self_name arguments returnT exceptionsT
                                                           bodyS])
                                               (do @
                                                 [bodyG (generation.with_context artifact_id
                                                          (generate archive bodyS))]
                                                 (wrap (_def.method #$.Public
                                                                    (if strict_fp?
                                                                      ($_ $.++M $.finalM $.strictM)
                                                                      $.finalM)
                                                                    name
                                                                    (type.method [(list@map product.right arguments)
                                                                                  returnT
                                                                                  exceptionsT])
                                                                    (|>> bodyG (returnI returnT)))))))
                                (\ @ map _def.fuse))
         #let [directive [anonymous_class_name
                          (_def.class #$.V1_6 #$.Public $.finalC
                                      anonymous_class_name (list)
                                      super_class super_interfaces
                                      (|>> (///function.with_environment total_environment)
                                           (..with_anonymous_init class total_environment super_class inputsTI)
                                           method_definitions))]]
         _ (generation.execute! directive)
         _ (generation.save! artifact_id directive)]
        (..anonymous_instance generate archive 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")
      (|> ..conversion
          (dictionary.merge ..int)
          (dictionary.merge ..long)
          (dictionary.merge ..float)
          (dictionary.merge ..double)
          (dictionary.merge ..char)
          (dictionary.merge ..array)
          (dictionary.merge ..object_bundle)
          (dictionary.merge ..member)
          (dictionary.merge ..bundle::class)
          )))