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

(template [<name>]
  [(exception: #export (<name> {message Text})
     message)]

  [invalid-syntax-for-jvm-type]
  [invalid-syntax-for-argument-generation]
  )

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

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

(template [<name> <unwrap> <conversion> <wrap>]
  [(def: (<name> inputI)
     (Unary Inst)
     (if (is? _.NOP <conversion>)
       inputI
       (|>> inputI
            <conversion>)))]
  
  [conversion::double-to-float #_t.Double _.D2F #_t.Float]
  [conversion::double-to-int #_t.Double _.D2I #_t.Int]
  [conversion::double-to-long #_t.Double _.D2L #_t.Long]
  [conversion::float-to-double #_t.Float _.F2D #_t.Double]
  [conversion::float-to-int #_t.Float _.F2I #_t.Int]
  [conversion::float-to-long #_t.Float _.F2L #_t.Long]
  [conversion::int-to-byte #_t.Int _.I2B #_t.Byte]
  [conversion::int-to-char #_t.Int _.I2C #_t.Char]
  [conversion::int-to-double #_t.Int _.I2D #_t.Double]
  [conversion::int-to-float #_t.Int _.I2F #_t.Float]
  [conversion::int-to-long #_t.Int _.I2L #_t.Long]
  [conversion::int-to-short #_t.Int _.I2S #_t.Short]
  [conversion::long-to-double #_t.Long _.L2D #_t.Double]
  [conversion::long-to-float #_t.Long _.L2F #_t.Float]
  [conversion::long-to-int #_t.Long _.L2I #_t.Int]
  [conversion::long-to-short #_t.Long L2S #_t.Short]
  [conversion::long-to-byte #_t.Long L2B #_t.Byte]
  [conversion::long-to-char #_t.Long L2C #_t.Char]
  [conversion::char-to-byte #_t.Char _.I2B #_t.Byte]
  [conversion::char-to-short #_t.Char _.I2S #_t.Short]
  [conversion::char-to-int #_t.Char _.NOP #_t.Int]
  [conversion::char-to-long #_t.Char _.I2L #_t.Long]
  [conversion::byte-to-long #_t.Byte _.I2L #_t.Long]
  [conversion::short-to-long #_t.Short _.I2L #_t.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-class (_t.class "java.lang.Boolean" (list)))
(def: falseI (_.GETSTATIC "java.lang.Boolean" "FALSE" boolean-class))
(def: trueI (_.GETSTATIC "java.lang.Boolean" "TRUE" boolean-class))

(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 "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 "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 "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 "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 "char")
      (|> (: Bundle bundle.empty)
          (bundle.install "=" (binary char::=))
          (bundle.install "<" (binary char::<))
          )))

(def: (array-java-type nesting elem-class)
  (-> Nat Text Type)
  (_t.array nesting
            (case elem-class
              "boolean" _t.boolean
              "byte" _t.byte
              "short" _t.short
              "int" _t.int
              "long" _t.long
              "float" _t.float
              "double" _t.double
              "char" _t.char
              _ (_t.class elem-class (list)))))

(def: (array::length 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 (_t.descriptor (array-java-type (.nat nesting) elem-class)))
                 _.ARRAYLENGTH)))

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

(def: (new-primitive-array-handler jvm-primitive)
  (-> Type Handler)
  (function (_ extension-name generate inputs)
    (case inputs
      (^ (list lengthS))
      (do phase.monad
        [lengthI (generate lengthS)]
        (wrap (|>> lengthI
                   (_.array (_t.array 1 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)
  (-> Type Inst Handler)
  (function (_ extension-name generate inputs)
    (case inputs
      (^ (list idxS arrayS))
      (do phase.monad
        [arrayI (generate arrayS)
         idxI (generate idxS)]
        (wrap (|>> arrayI
                   (_.CHECKCAST (_t.descriptor (_t.array 1 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 (_t.descriptor (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)
  (-> Type 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 (_t.descriptor (_t.array 1 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 (_t.descriptor (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
          (bundle.install "length" array::length)
          (dictionary.merge (<| (bundle.prefix "new")
                                (|> bundle.empty
                                    (bundle.install "boolean" (new-primitive-array-handler _t.boolean))
                                    (bundle.install "byte" (new-primitive-array-handler _t.byte))
                                    (bundle.install "short" (new-primitive-array-handler _t.short))
                                    (bundle.install "int" (new-primitive-array-handler _t.int))
                                    (bundle.install "long" (new-primitive-array-handler _t.long))
                                    (bundle.install "float" (new-primitive-array-handler _t.float))
                                    (bundle.install "double" (new-primitive-array-handler _t.double))
                                    (bundle.install "char" (new-primitive-array-handler _t.char))
                                    (bundle.install "object" array::new::object))))
          (dictionary.merge (<| (bundle.prefix "read")
                                (|> bundle.empty
                                    (bundle.install "boolean" (read-primitive-array-handler _t.boolean _.BALOAD))
                                    (bundle.install "byte" (read-primitive-array-handler _t.byte _.BALOAD))
                                    (bundle.install "short" (read-primitive-array-handler _t.short _.SALOAD))
                                    (bundle.install "int" (read-primitive-array-handler _t.int _.IALOAD))
                                    (bundle.install "long" (read-primitive-array-handler _t.long _.LALOAD))
                                    (bundle.install "float" (read-primitive-array-handler _t.float _.FALOAD))
                                    (bundle.install "double" (read-primitive-array-handler _t.double _.DALOAD))
                                    (bundle.install "char" (read-primitive-array-handler _t.char _.CALOAD))
                                    (bundle.install "object" array::read::object))))
          (dictionary.merge (<| (bundle.prefix "write")
                                (|> bundle.empty
                                    (bundle.install "boolean" (write-primitive-array-handler _t.boolean _.BASTORE))
                                    (bundle.install "byte" (write-primitive-array-handler _t.byte _.BASTORE))
                                    (bundle.install "short" (write-primitive-array-handler _t.short _.SASTORE))
                                    (bundle.install "int" (write-primitive-array-handler _t.int _.IASTORE))
                                    (bundle.install "long" (write-primitive-array-handler _t.long _.LASTORE))
                                    (bundle.install "float" (write-primitive-array-handler _t.float _.FASTORE))
                                    (bundle.install "double" (write-primitive-array-handler _t.double _.DASTORE))
                                    (bundle.install "char" (write-primitive-array-handler _t.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: (object::class extension-name generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class)))
    (do phase.monad
      []
      (wrap (|>> (_.string class)
                 (_.INVOKESTATIC "java.lang.Class" "forName"
                                 (_t.method (list (_t.class "java.lang.String" (list)))
                                            (#.Some (_t.class "java.lang.Class" (list)))
                                            (list))
                                 false))))

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

(def: (object::instance? extension-name generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class) objectS))
    (do phase.monad
      [objectI (generate objectS)]
      (wrap (|>> objectI
                 (_.INSTANCEOF class)
                 (_.wrap #_t.Boolean))))

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

(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>]
          [<primitive> <object>]
          (wrap (|>> valueI (_.wrap <type>)))

          [<object> <primitive>]
          (wrap (|>> valueI (_.unwrap <type>))))
        (["boolean" "java.lang.Boolean"   #_t.Boolean]
         ["byte"    "java.lang.Byte"      #_t.Byte]
         ["short"   "java.lang.Short"     #_t.Short]
         ["int"     "java.lang.Integer"   #_t.Int]
         ["long"    "java.lang.Long"      #_t.Long]
         ["float"   "java.lang.Float"     #_t.Float]
         ["double"  "java.lang.Double"    #_t.Double]
         ["char"    "java.lang.Character" #_t.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 Primitive)
  (|> (list ["boolean" #_t.Boolean]
            ["byte" #_t.Byte]
            ["short" #_t.Short]
            ["int" #_t.Int]
            ["long" #_t.Long]
            ["float" #_t.Float]
            ["double" #_t.Double]
            ["char" #_t.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 class field (#_t.Primitive primitive)))
        
        #.None
        (wrap (_.GETSTATIC class field (_t.class unboxed (list))))))

    _
    (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)]
      (case (dictionary.get unboxed primitives)
        (#.Some primitive)
        (wrap (|>> valueI
                   (_.PUTSTATIC class field (#_t.Primitive primitive))
                   (_.string synthesis.unit)))
        
        #.None
        (wrap (|>> valueI
                   (_.CHECKCAST class)
                   (_.PUTSTATIC class field (_t.class class (list)))
                   (_.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)]
      (case (dictionary.get unboxed primitives)
        (#.Some primitive)
        (wrap (|>> objectI
                   (_.CHECKCAST class)
                   (_.GETFIELD class field (#_t.Primitive primitive))))
        
        #.None
        (wrap (|>> objectI
                   (_.CHECKCAST class)
                   (_.GETFIELD class field (_t.class unboxed (list)))))))

    _
    (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)]
      (case (dictionary.get unboxed primitives)
        (#.Some primitive)
        (wrap (|>> objectI
                   (_.CHECKCAST class)
                   _.DUP
                   valueI
                   (_.PUTFIELD class field (#_t.Primitive primitive))))
        
        #.None
        (wrap (|>> objectI
                   (_.CHECKCAST class)
                   _.DUP
                   valueI
                   (_.CHECKCAST unboxed)
                   (_.PUTFIELD class field (_t.class unboxed (list)))))))

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

(def: base-type
  (<t>.Parser Type)
  ($_ <>.either
      (<>.after (<t>.this "boolean") (<>@wrap _t.boolean))
      (<>.after (<t>.this "byte") (<>@wrap _t.byte))
      (<>.after (<t>.this "short") (<>@wrap _t.short))
      (<>.after (<t>.this "int") (<>@wrap _t.int))
      (<>.after (<t>.this "long") (<>@wrap _t.long))
      (<>.after (<t>.this "float") (<>@wrap _t.float))
      (<>.after (<t>.this "double") (<>@wrap _t.double))
      (<>.after (<t>.this "char") (<>@wrap _t.char))
      (<>@map (function (_ name)
                (_t.class name (list)))
              (<t>.many (<t>.none-of "[")))
      ))

(def: java-type
  (<t>.Parser Type)
  (do <>.monad
    [raw base-type
     nesting (<>.some (<t>.this "[]"))]
    (wrap (_t.array (list.size nesting) raw))))

(def: (generate-type argD)
  (-> Text (Operation Type))
  (case (<t>.run java-type argD)
    (#error.Failure error)
    (phase.throw invalid-syntax-for-jvm-type argD)

    (#error.Success type)
    (phase@wrap type)))

(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 (generate-type argD)
       argI (generate argS)]
      (wrap [argT argI]))

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

(def: (method-return-type description)
  (-> Text (Operation (Maybe Type)))
  (case description
    "void"
    (phase@wrap #.None)

    _
    (phase@map (|>> #.Some) (generate-type description))))

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

    #.None
    argI))

(def: (invoke::static extension-name generate inputs)
  Handler
  (case inputs
    (^ (list& (synthesis.text class)
              (synthesis.text method)
              (synthesis.text 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
                                 (_t.method (list@map product.left argsTI) returnT (list))
                                 false))))

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

(template [<name> <invoke> <interface?>]
  [(def: (<name> extension-name generate inputs)
     Handler
     (case inputs
       (^ (list& (synthesis.text class)
                 (synthesis.text method)
                 (synthesis.text 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
                              (_t.method (list@map product.left argsTI) returnT (list))
                              <interface?>))))

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

  [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>"
                                  (_t.method (list@map product.left argsTI) #.None (list))
                                  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: (custom [parser handler])
  (All [s]
    (-> [(<s>.Parser s)
         (-> Text Phase s (Operation Inst))]
        Handler))
  (function (_ extension-name phase input)
    (case (<s>.run input parser)
      (#error.Success input')
      (handler extension-name phase input')

      (#error.Failure error)
      (phase.throw extension.invalid-syntax [extension-name %synthesis input]))))

(def: var
  (<s>.Parser Var)
  <s>.text)

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

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

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

(def: class
  (<s>.Parser Class)
  (class' ..generic))

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

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

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

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

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

(def: argument
  (<s>.Parser Argument)
  (<s>.tuple (<>.and <s>.text ..jvm-type)))

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

(def: overriden-method-definition
  (<s>.Parser [Environment (/.Overriden-Method Synthesis)])
  (<s>.tuple (do <>.monad
               [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: 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 [global-mapping (|> overriden-methods
                                  ## Get all the environments.
                                  (list@map product.left)
                                  ## Combine them.
                                  list@join
                                  ## Remove duplicates.
                                  (set.from-list reference.hash)
                                  set.to-list
                                  ## 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)]
         ## _ (generation.save! true ["" function-class]
         ##                     [function-class
         ##                      (def.class #$.V1_6 #$.Public $.finalC
         ##                                 function-class (list)
         ##                                 ($.simple-class //.function-class) (list)
         ##                                 functionD)])
         _ (phase.throw extension.invalid-syntax ["YOLO-TRON" %synthesis (list)])]
        (wrap _.DUP)))]))

(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)
          )))