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

(exception: #export invalid-syntax-for-argument-generation)

(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> [xI yI])
     (Binary Inst)
     (|>> xI
          yI
          <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 (descriptor.class box.boolean))
(def: falseI (_.GETSTATIC $Boolean "FALSE" $Boolean))
(def: trueI (_.GETSTATIC $Boolean "TRUE" $Boolean))

(template [<name> <op>]
  [(def: (<name> [xI yI])
     (Binary Inst)
     (<| _.with-label (function (_ @then))
         _.with-label (function (_ @end))
         (|>> xI
              yI
              (<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> [xI yI])
     (Binary Inst)
     (<| _.with-label (function (_ @then))
         _.with-label (function (_ @end))
         (|>> xI
              yI
              <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.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.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.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.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.char)
      (|> (: Bundle bundle.empty)
          (bundle.install "=" (binary char::=))
          (bundle.install "<" (binary char::<))
          )))

(def: (array-java-type nesting elem-class)
  (-> Nat Text (Descriptor Object))
  (descriptor.array (case nesting
                      1 (case elem-class
                          (^ (static reflection.boolean)) descriptor.boolean
                          (^ (static reflection.byte)) descriptor.byte
                          (^ (static reflection.short)) descriptor.short
                          (^ (static reflection.int)) descriptor.int
                          (^ (static reflection.long)) descriptor.long
                          (^ (static reflection.float)) descriptor.float
                          (^ (static reflection.double)) descriptor.double
                          (^ (static reflection.char)) descriptor.char
                          _ (descriptor.class elem-class))
                      _ (array-java-type (dec nesting) elem-class))))

(def: (primitive-array-length-handler jvm-primitive)
  (-> (Descriptor Primitive) Handler)
  (..custom
   [<s>.any
    (function (_ extension-name generate arrayS)
      (do phase.monad
        [arrayI (generate arrayS)]
        (wrap (|>> arrayI
                   (_.CHECKCAST (descriptor.array jvm-primitive))
                   _.ARRAYLENGTH))))]))

(def: (array::length::object extension-name generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.i64 nesting)
             (synthesis.text elem-class)
             arrayS))
    (do phase.monad
      [arrayI (generate arrayS)]
      (wrap (|>> arrayI
                 (_.CHECKCAST (array-java-type (.nat nesting) elem-class))
                 _.ARRAYLENGTH)))

    _
    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))

(def: (new-primitive-array-handler jvm-primitive)
  (-> (Descriptor Primitive) Handler)
  (function (_ extension-name generate inputs)
    (case inputs
      (^ (list lengthS))
      (do phase.monad
        [lengthI (generate lengthS)]
        (wrap (|>> lengthI
                   (_.array jvm-primitive))))

      _
      (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))

(def: (array::new::object extension-name generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.i64 nesting)
             (synthesis.text elem-class)
             lengthS))
    (do phase.monad
      [lengthI (generate lengthS)]
      (wrap (|>> lengthI
                 (_.array (array-java-type (.nat nesting) elem-class)))))

    _
    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))

(def: (read-primitive-array-handler jvm-primitive loadI)
  (-> (Descriptor Primitive) Inst Handler)
  (function (_ extension-name generate inputs)
    (case inputs
      (^ (list idxS arrayS))
      (do phase.monad
        [arrayI (generate arrayS)
         idxI (generate idxS)]
        (wrap (|>> arrayI
                   (_.CHECKCAST (descriptor.array jvm-primitive))
                   idxI
                   loadI)))

      _
      (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))

(def: (array::read::object extension-name generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.i64 nesting)
             (synthesis.text elem-class)
             idxS
             arrayS))
    (do phase.monad
      [arrayI (generate arrayS)
       idxI (generate idxS)]
      (wrap (|>> arrayI
                 (_.CHECKCAST (array-java-type (.nat nesting) elem-class))
                 idxI
                 _.AALOAD)))

    _
    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))

(def: (write-primitive-array-handler jvm-primitive storeI)
  (-> (Descriptor Primitive) Inst Handler)
  (function (_ extension-name generate inputs)
    (case inputs
      (^ (list idxS valueS arrayS))
      (do phase.monad
        [arrayI (generate arrayS)
         idxI (generate idxS)
         valueI (generate valueS)]
        (wrap (|>> arrayI
                   (_.CHECKCAST (descriptor.array jvm-primitive))
                   _.DUP
                   idxI
                   valueI
                   storeI)))

      _
      (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))

(def: (array::write::object extension-name generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.i64 nesting)
             (synthesis.text elem-class)
             idxS
             valueS
             arrayS))
    (do phase.monad
      [arrayI (generate arrayS)
       idxI (generate idxS)
       valueI (generate valueS)]
      (wrap (|>> arrayI
                 (_.CHECKCAST (array-java-type (.nat nesting) elem-class))
                 _.DUP
                 idxI
                 valueI
                 _.AASTORE)))

    _
    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))

(def: array
  Bundle
  (<| (bundle.prefix "array")
      (|> bundle.empty
          (dictionary.merge (<| (bundle.prefix "length")
                                (|> bundle.empty
                                    (bundle.install reflection.boolean (primitive-array-length-handler descriptor.boolean))
                                    (bundle.install reflection.byte (primitive-array-length-handler descriptor.byte))
                                    (bundle.install reflection.short (primitive-array-length-handler descriptor.short))
                                    (bundle.install reflection.int (primitive-array-length-handler descriptor.int))
                                    (bundle.install reflection.long (primitive-array-length-handler descriptor.long))
                                    (bundle.install reflection.float (primitive-array-length-handler descriptor.float))
                                    (bundle.install reflection.double (primitive-array-length-handler descriptor.double))
                                    (bundle.install reflection.char (primitive-array-length-handler descriptor.char))
                                    (bundle.install "object" array::length::object))))
          (dictionary.merge (<| (bundle.prefix "new")
                                (|> bundle.empty
                                    (bundle.install reflection.boolean (new-primitive-array-handler descriptor.boolean))
                                    (bundle.install reflection.byte (new-primitive-array-handler descriptor.byte))
                                    (bundle.install reflection.short (new-primitive-array-handler descriptor.short))
                                    (bundle.install reflection.int (new-primitive-array-handler descriptor.int))
                                    (bundle.install reflection.long (new-primitive-array-handler descriptor.long))
                                    (bundle.install reflection.float (new-primitive-array-handler descriptor.float))
                                    (bundle.install reflection.double (new-primitive-array-handler descriptor.double))
                                    (bundle.install reflection.char (new-primitive-array-handler descriptor.char))
                                    (bundle.install "object" array::new::object))))
          (dictionary.merge (<| (bundle.prefix "read")
                                (|> bundle.empty
                                    (bundle.install reflection.boolean (read-primitive-array-handler descriptor.boolean _.BALOAD))
                                    (bundle.install reflection.byte (read-primitive-array-handler descriptor.byte _.BALOAD))
                                    (bundle.install reflection.short (read-primitive-array-handler descriptor.short _.SALOAD))
                                    (bundle.install reflection.int (read-primitive-array-handler descriptor.int _.IALOAD))
                                    (bundle.install reflection.long (read-primitive-array-handler descriptor.long _.LALOAD))
                                    (bundle.install reflection.float (read-primitive-array-handler descriptor.float _.FALOAD))
                                    (bundle.install reflection.double (read-primitive-array-handler descriptor.double _.DALOAD))
                                    (bundle.install reflection.char (read-primitive-array-handler descriptor.char _.CALOAD))
                                    (bundle.install "object" array::read::object))))
          (dictionary.merge (<| (bundle.prefix "write")
                                (|> bundle.empty
                                    (bundle.install reflection.boolean (write-primitive-array-handler descriptor.boolean _.BASTORE))
                                    (bundle.install reflection.byte (write-primitive-array-handler descriptor.byte _.BASTORE))
                                    (bundle.install reflection.short (write-primitive-array-handler descriptor.short _.SASTORE))
                                    (bundle.install reflection.int (write-primitive-array-handler descriptor.int _.IASTORE))
                                    (bundle.install reflection.long (write-primitive-array-handler descriptor.long _.LASTORE))
                                    (bundle.install reflection.float (write-primitive-array-handler descriptor.float _.FASTORE))
                                    (bundle.install reflection.double (write-primitive-array-handler descriptor.double _.DASTORE))
                                    (bundle.install reflection.char (write-primitive-array-handler descriptor.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 (descriptor.class "java.lang.Class"))

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

    _
    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))

(def: object::instance?
  Handler
  (..custom
   [($_ <>.and <s>.text <s>.any)
    (function (_ extension-name generate [class objectS])
      (do phase.monad
        [objectI (generate objectS)]
        (wrap (|>> objectI
                   (_.INSTANCEOF (descriptor.class class))
                   (_.wrap descriptor.boolean)))))]))

(def: (object::cast extension-name generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text from) (synthesis.text to) valueS))
    (do phase.monad
      [valueI (generate valueS)]
      (case [from to]
        ## Wrap
        (^template [<primitive> <object> <type>]
          (^ [(static <primitive>) (static <object>)])
          (wrap (|>> valueI (_.wrap <type>)))

          (^ [(static <object>) (static <primitive>)])
          (wrap (|>> valueI (_.unwrap <type>))))
        ([reflection.boolean box.boolean descriptor.boolean]
         [reflection.byte    box.byte    descriptor.byte]
         [reflection.short   box.short   descriptor.short]
         [reflection.int     box.int     descriptor.int]
         [reflection.long    box.long    descriptor.long]
         [reflection.float   box.float   descriptor.float]
         [reflection.double  box.double  descriptor.double]
         [reflection.char    box.char    descriptor.char])
        
        _
        (wrap valueI)))

    _
    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))

(def: 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 (Descriptor Primitive))
  (|> (list [reflection.boolean descriptor.boolean]
            [reflection.byte descriptor.byte]
            [reflection.short descriptor.short]
            [reflection.int descriptor.int]
            [reflection.long descriptor.long]
            [reflection.float descriptor.float]
            [reflection.double descriptor.double]
            [reflection.char descriptor.char])
      (dictionary.from-list text.hash)))

(def: (static::get extension-name generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class)
             (synthesis.text field)
             (synthesis.text unboxed)))
    (do phase.monad
      []
      (case (dictionary.get unboxed ..primitives)
        (#.Some primitive)
        (wrap (_.GETSTATIC (descriptor.class class) field primitive))
        
        #.None
        (wrap (_.GETSTATIC (descriptor.class class) field (descriptor.class unboxed)))))

    _
    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))

(def: (static::put extension-name generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class)
             (synthesis.text field)
             (synthesis.text unboxed)
             valueS))
    (do phase.monad
      [valueI (generate valueS)
       #let [$class (descriptor.class class)]]
      (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)))))

    _
    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))

(def: (virtual::get extension-name generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class)
             (synthesis.text field)
             (synthesis.text unboxed)
             objectS))
    (do phase.monad
      [objectI (generate objectS)
       #let [$class (descriptor.class class)
             getI (case (dictionary.get unboxed ..primitives)
                    (#.Some primitive)
                    (_.GETFIELD $class field primitive)
                    
                    #.None
                    (_.GETFIELD $class field (descriptor.class unboxed)))]]
      (wrap (|>> objectI
                 (_.CHECKCAST $class)
                 getI)))

    _
    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))

(def: (virtual::put extension-name generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class)
             (synthesis.text field)
             (synthesis.text unboxed)
             valueS
             objectS))
    (do phase.monad
      [valueI (generate valueS)
       objectI (generate objectS)
       #let [$class (descriptor.class class)
             putI (case (dictionary.get unboxed ..primitives)
                    (#.Some primitive)
                    (_.PUTFIELD $class field primitive)
                    
                    #.None
                    (let [$unboxed (descriptor.class unboxed)]
                      (|>> (_.CHECKCAST $unboxed)
                           (_.PUTFIELD $class field $unboxed))))]]
      (wrap (|>> objectI
                 (_.CHECKCAST $class)
                 _.DUP
                 valueI
                 putI)))

    _
    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))

(def: (generate-arg generate argS)
  (-> (-> Synthesis (Operation Inst)) Synthesis
      (Operation [Type Inst]))
  (case argS
    (^ (synthesis.tuple (list (synthesis.text argD) argS)))
    (do phase.monad
      [argT (phase.lift (<t>.run jvm.parse-signature argD))
       argI (generate argS)]
      (wrap [argT argI]))

    _
    (phase.throw invalid-syntax-for-argument-generation [])))

(def: (method-return-type description)
  (-> Text (Operation Return))
  (case description
    (^ (static descriptor.void))
    (phase@wrap #.None)

    _
    (|> description
        (<t>.run jvm.parse-signature)
        phase.lift
        (phase@map (|>> #.Some)))))

(def: (prepare-argI [type argI])
  (-> [Type Inst] Inst)
  (case (jvm.class-name type)
    (#.Some class-name)
    (|>> argI
         (_.CHECKCAST class-name))

    #.None
    argI))

(def: (prepare-returnI return)
  (-> Return Inst)
  (case return
    (#.Some _)
    function.identity

    #.None
    (_.string synthesis.unit)))

(def: invoke::static
  Handler
  (..custom
   [($_ <>.and <s>.text <s>.text <s>.text (<>.some <s>.any))
    (function (_ extension-name generate [class method unboxed argsS])
      (do phase.monad
        [argsTI (monad.map @ (generate-arg generate) argsS)
         returnT (method-return-type unboxed)]
        (wrap (|>> (_.fuse (list@map ..prepare-argI argsTI))
                   (_.INVOKESTATIC class method
                                   (descriptor.method [(list@map product.left argsTI)
                                                       returnT])
                                   false)
                   (prepare-returnI returnT)))))]))

(template [<name> <invoke> <interface?>]
  [(def: <name>
     Handler
     (..custom
      [($_ <>.and <s>.text <s>.text <s>.text <s>.any (<>.some <s>.any))
       (function (_ extension-name generate [class method unboxed objectS argsS])
         (do phase.monad
           [objectI (generate objectS)
            argsTI (monad.map @ (generate-arg generate) argsS)
            returnT (method-return-type unboxed)]
           (wrap (|>> objectI
                      (_.CHECKCAST class)
                      (_.fuse (list@map ..prepare-argI argsTI))
                      (<invoke> class method
                                (descriptor.method [(list@map product.left argsTI)
                                                    returnT])
                                <interface?>)
                      (prepare-returnI returnT)))))]))]

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

(def: (invoke::constructor extension-name generate inputs)
  Handler
  (case inputs
    (^ (list& (synthesis.text class) argsS))
    (do phase.monad
      [argsTI (monad.map @ (generate-arg generate) argsS)]
      (wrap (|>> (_.NEW class)
                 _.DUP
                 (_.fuse (list@map ..prepare-argI argsTI))
                 (_.INVOKESPECIAL class "<init>"
                                  (descriptor.method [(list@map product.left argsTI)
                                                      descriptor.void])
                                  false))))

    _
    (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))

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

(def: bound
  (Parser Bound)
  (<>.or (<s>.constant! ["" ">"])
         (<s>.constant! ["" "<"])))

(def: (class' generic)
  (-> (Parser Generic) (Parser Class))
  (<s>.tuple (<>.and <s>.text (<>.some generic))))

(def: generic
  (Parser Generic)
  (<>.rec
   (function (_ generic)
     (let [wildcard (<>.or (<s>.constant! ["" "?"])
                           (<s>.tuple (<>.and ..bound generic)))]
       ($_ <>.or
           ..var
           wildcard
           (class' generic))))))

(def: class
  (Parser Class)
  (class' ..generic))

(def: primitive
  (Parser (Descriptor Primitive))
  ($_ <>.or
      (<>.after (<s>.constant! ["" reflection.boolean])
                (<>@wrap descriptor.boolean))
      (<>.after (<s>.constant! ["" reflection.byte])
                (<>@wrap descriptor.byte))
      (<>.after (<s>.constant! ["" reflection.short])
                (<>@wrap descriptor.short))
      (<>.after (<s>.constant! ["" reflection.int])
                (<>@wrap descriptor.int))
      (<>.after (<s>.constant! ["" reflection.long])
                (<>@wrap descriptor.long))
      (<>.after (<s>.constant! ["" reflection.float])
                (<>@wrap descriptor.float))
      (<>.after (<s>.constant! ["" reflection.double])
                (<>@wrap descriptor.double))
      (<>.after (<s>.constant! ["" reflection.char])
                (<>@wrap descriptor.char))
      ))

(def: jvm-type
  (Parser Type)
  (<>.rec
   (function (_ jvm-type)
     ($_ <>.or
         ..primitive
         ..generic
         (<s>.tuple jvm-type)))))

(def: constructor-arg
  (Parser (Typed Synthesis))
  (<s>.tuple (<>.and ..jvm-type <s>.any)))

(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 ..jvm-type)))

(def: return
  (Parser Return)
  (<>.or (<s>.constant! ["" (descriptor.descriptor descriptor.void)])
         ..jvm-type))

(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 (descriptor.class "java.lang.Object"))

(def: (anonymous-init-method env)
  (-> Environment (Descriptor Method))
  (descriptor.method [(list.repeat (list.size env) $Object)
                      descriptor.void]))

(def: (with-anonymous-init class env super-class constructor-argsI)
  (-> Text Environment 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 constructor-argsI)))
                      (_.INVOKESPECIAL (product.left super-class)
                                       "<init>"
                                       (descriptor.method [(list@map product.left constructor-argsI)
                                                           descriptor.void])
                                       #0)
                      store-capturedI
                      _.RETURN))))

(def: (anonymous-instance class env)
  (-> Text Environment (Operation Inst))
  (do phase.monad
    [captureI+ (monad.map @ ///reference.variable env)]
    (wrap (|>> (_.NEW class)
               _.DUP
               (_.fuse captureI+)
               (_.INVOKESPECIAL class "<init>" (anonymous-init-method env) #0)))))

(def: class::anonymous
  Handler
  (..custom
   [($_ <>.and
        <s>.text
        ..class
        (<s>.tuple (<>.some ..class))
        (<s>.tuple (<>.some ..constructor-arg))
        (<s>.tuple (<>.some ..overriden-method-definition)))
    (function (_ extension-name generate [class-name
                                          super-class super-interfaces
                                          constructor-args
                                          overriden-methods])
      (do phase.monad
        [#let [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)]
         constructor-argsI (monad.map @
                                      (function (_ [argJT argS])
                                        (do @
                                          [argG (generate argS)]
                                          (wrap [argJT argG])))
                                      constructor-args)
         method-definitions (|> normalized-methods
                                (monad.map @ (function (_ [ownerT name
                                                           strict-fp? annotations vars
                                                           self-name arguments returnT exceptionsT
                                                           bodyS])
                                               (do @
                                                 [bodyG (generate bodyS)]
                                                 (wrap (_def.method #$.Public
                                                                    (if strict-fp?
                                                                      ($_ $.++M $.finalM $.strictM)
                                                                      $.finalM)
                                                                    name
                                                                    (descriptor.method [(list@map product.right arguments)
                                                                                        returnT]
                                                                                       ## (list@map (|>> #jvm.Class)
                                                                                       ##           exceptionsT)
                                                                                       )
                                                                    (let [returnI (case returnT
                                                                                    (#.Some returnT)
                                                                                    (case returnT
                                                                                      (#jvm.Primitive returnT)
                                                                                      (case returnT
                                                                                        (^or #jvm.Boolean
                                                                                             #jvm.Byte #jvm.Short #jvm.Int
                                                                                             #jvm.Char)
                                                                                        _.IRETURN
                                                                                        
                                                                                        #jvm.Long
                                                                                        _.LRETURN
                                                                                        
                                                                                        #jvm.Float
                                                                                        _.FRETURN
                                                                                        
                                                                                        #jvm.Double
                                                                                        _.DRETURN)
                                                                                      
                                                                                      _
                                                                                      _.ARETURN)

                                                                                    #.None
                                                                                    _.RETURN)]
                                                                      (|>> bodyG returnI)))))))
                                (:: @ map _def.fuse))
         _ (generation.save! true ["" class-name]
                             [class-name
                              (_def.class #$.V1_6 #$.Public $.finalC
                                          class-name (list)
                                          super-class super-interfaces
                                          (|>> (///function.with-environment total-environment)
                                               (..with-anonymous-init class-name total-environment super-class constructor-argsI)
                                               method-definitions))])]
        (anonymous-instance class-name 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)
          (dictionary.merge ..member)
          (dictionary.merge ..bundle::class)
          )))