path: root/lux-jvm/source/luxc/lang/directive/jvm.lux

(.module:
  [library
   [lux {"-" Type Primitive static local}
    ["[0]" ffi {"+" Inheritance Privacy State import:}]
    [abstract
     ["[0]" monad {"+" do}]]
    [control
     [pipe {"+" case>}]
     ["[0]" try {"+" Try}]
     ["<>" parser
      ["<[0]>" code {"+" Parser}]
      ["<[0]>" text]]]
    [data
     [identity {"+" Identity}]
     [binary {"+" Binary}]
     ["[0]" product]
     [text
      ["%" format {"+" format}]]
     [collection
      [array {"+" Array}]
      ["[0]" list ("[1]#[0]" mix functor monoid)]
      ["[0]" dictionary {"+" Dictionary}]
      ["[0]" row {"+" Row} ("[1]#[0]" functor mix)]]]
    [math
     [number
      ["[0]" nat]]]
    [target
     ["/" jvm
      [encoding
       ["[0]" name {"+" External}]]
      ["[1][0]" type {"+" Type Constraint}
       [category {"+" Void Value Return Primitive Object Class Var Parameter}]
       ["[0]" parser]
       ["[0]T" lux]
       ["[1]/[0]" signature]
       ["[1]/[0]" descriptor]]]]
    [tool
     [compiler
      ["[0]" phase]
      [language
       [lux
        ["[0]" analysis {"+" Analysis}]
        ["[0]" synthesis {"+" Synthesis}]
        ["[0]" generation]
        ["[0]" directive {"+" Requirements}]
        [phase
         [analysis
          ["[0]A" scope]
          ["[0]A" type]]
         ["[0]" extension
          ["[0]" bundle]
          [analysis
           ["//A" jvm]]
          [directive
           ["[0]/" lux]]]]]]
      [meta
       [archive {"+" Archive}]]]]]]
  [///
   [host
    ["[0]" jvm {"+" Inst}
     ["_" inst]
     ["[0]" def]]]
   [translation
    [jvm
     [extension
      ["//G" host]]]]])

(import: org/objectweb/asm/Label
  ["[1]::[0]"
   (new [])])

(def: (literal literal)
  (-> /.Literal Inst)
  (case literal
    {/.#Boolean value} (_.boolean value)
    {/.#Int value} (_.int value)
    {/.#Long value} (_.long value)
    {/.#Double value} (_.double value)
    {/.#Char value} (_.char value)
    {/.#String value} (_.string value)))

(def: (constant instruction)
  (-> /.Constant Inst)
  (case instruction
    {/.#BIPUSH constant} (_.BIPUSH constant)
    
    {/.#SIPUSH constant} (_.SIPUSH constant)

    {/.#ICONST_M1} _.ICONST_M1
    {/.#ICONST_0} _.ICONST_0
    {/.#ICONST_1} _.ICONST_1
    {/.#ICONST_2} _.ICONST_2
    {/.#ICONST_3} _.ICONST_3
    {/.#ICONST_4} _.ICONST_4
    {/.#ICONST_5} _.ICONST_5

    {/.#LCONST_0} _.LCONST_0
    {/.#LCONST_1} _.LCONST_1
    
    {/.#FCONST_0} _.FCONST_0
    {/.#FCONST_1} _.FCONST_1
    {/.#FCONST_2} _.FCONST_2
    
    {/.#DCONST_0} _.DCONST_0
    {/.#DCONST_1} _.DCONST_1
    
    {/.#ACONST_NULL} _.NULL

    {/.#LDC literal}
    (..literal literal)
    ))

(def: (int_arithmetic instruction)
  (-> /.Int_Arithmetic Inst)
  (case instruction
    {/.#IADD} _.IADD
    {/.#ISUB} _.ISUB
    {/.#IMUL} _.IMUL
    {/.#IDIV} _.IDIV
    {/.#IREM} _.IREM
    {/.#INEG} _.INEG))

(def: (long_arithmetic instruction)
  (-> /.Long_Arithmetic Inst)
  (case instruction
    {/.#LADD} _.LADD
    {/.#LSUB} _.LSUB
    {/.#LMUL} _.LMUL
    {/.#LDIV} _.LDIV
    {/.#LREM} _.LREM
    {/.#LNEG} _.LNEG))

(def: (float_arithmetic instruction)
  (-> /.Float_Arithmetic Inst)
  (case instruction
    {/.#FADD} _.FADD
    {/.#FSUB} _.FSUB
    {/.#FMUL} _.FMUL
    {/.#FDIV} _.FDIV
    {/.#FREM} _.FREM
    {/.#FNEG} _.FNEG))

(def: (double_arithmetic instruction)
  (-> /.Double_Arithmetic Inst)
  (case instruction
    {/.#DADD} _.DADD
    {/.#DSUB} _.DSUB
    {/.#DMUL} _.DMUL
    {/.#DDIV} _.DDIV
    {/.#DREM} _.DREM
    {/.#DNEG} _.DNEG))

(def: (arithmetic instruction)
  (-> /.Arithmetic Inst)
  (case instruction
    {/.#Int_Arithmetic int_arithmetic}
    (..int_arithmetic int_arithmetic)
    
    {/.#Long_Arithmetic long_arithmetic}
    (..long_arithmetic long_arithmetic)
    
    {/.#Float_Arithmetic float_arithmetic}
    (..float_arithmetic float_arithmetic)
    
    {/.#Double_Arithmetic double_arithmetic}
    (..double_arithmetic double_arithmetic)))

(def: (int_bitwise instruction)
  (-> /.Int_Bitwise Inst)
  (case instruction
    {/.#IOR} _.IOR
    {/.#IXOR} _.IXOR
    {/.#IAND} _.IAND
    {/.#ISHL} _.ISHL
    {/.#ISHR} _.ISHR
    {/.#IUSHR} _.IUSHR))

(def: (long_bitwise instruction)
  (-> /.Long_Bitwise Inst)
  (case instruction
    {/.#LOR} _.LOR
    {/.#LXOR} _.LXOR
    {/.#LAND} _.LAND
    {/.#LSHL} _.LSHL
    {/.#LSHR} _.LSHR
    {/.#LUSHR} _.LUSHR))

(def: (bitwise instruction)
  (-> /.Bitwise Inst)
  (case instruction
    {/.#Int_Bitwise int_bitwise}
    (..int_bitwise int_bitwise)
    
    {/.#Long_Bitwise long_bitwise}
    (..long_bitwise long_bitwise)))

(def: (conversion instruction)
  (-> /.Conversion Inst)
  (case instruction
    {/.#I2B} _.I2B
    {/.#I2S} _.I2S
    {/.#I2L} _.I2L
    {/.#I2F} _.I2F
    {/.#I2D} _.I2D
    {/.#I2C} _.I2C

    {/.#L2I} _.L2I
    {/.#L2F} _.L2F
    {/.#L2D} _.L2D

    {/.#F2I} _.F2I
    {/.#F2L} _.F2L
    {/.#F2D} _.F2D
    
    {/.#D2I} _.D2I
    {/.#D2L} _.D2L
    {/.#D2F} _.D2F))

(def: (array instruction)
  (-> /.Array Inst)
  (case instruction
    {/.#ARRAYLENGTH} _.ARRAYLENGTH

    {/.#NEWARRAY type} (_.NEWARRAY type)
    {/.#ANEWARRAY type} (_.ANEWARRAY type)

    {/.#BALOAD} _.BALOAD
    {/.#BASTORE} _.BASTORE

    {/.#SALOAD} _.SALOAD
    {/.#SASTORE} _.SASTORE

    {/.#IALOAD} _.IALOAD
    {/.#IASTORE} _.IASTORE

    {/.#LALOAD} _.LALOAD
    {/.#LASTORE} _.LASTORE

    {/.#FALOAD} _.FALOAD
    {/.#FASTORE} _.FASTORE

    {/.#DALOAD} _.DALOAD
    {/.#DASTORE} _.DASTORE
    
    {/.#CALOAD} _.CALOAD
    {/.#CASTORE} _.CASTORE

    {/.#AALOAD} _.AALOAD
    {/.#AASTORE} _.AASTORE))

(def: (object instruction)
  (-> /.Object Inst)
  (case instruction
    (^template [<tag> <inst>]
      [{<tag> class field_name field_type}
       (<inst> class field_name field_type)])
    ([/.#GETSTATIC _.GETSTATIC]
     [/.#PUTSTATIC _.PUTSTATIC]
     [/.#GETFIELD _.GETFIELD]
     [/.#PUTFIELD _.PUTFIELD])
    
    {/.#NEW type} (_.NEW type)
    
    {/.#INSTANCEOF type} (_.INSTANCEOF type)
    {/.#CHECKCAST type} (_.CHECKCAST type)

    (^template [<tag> <inst>]
      [{<tag> class method_name method_type}
       (<inst> class method_name method_type)])
    ([/.#INVOKEINTERFACE _.INVOKEINTERFACE]
     [/.#INVOKESPECIAL _.INVOKESPECIAL]
     [/.#INVOKESTATIC _.INVOKESTATIC]
     [/.#INVOKEVIRTUAL _.INVOKEVIRTUAL])
    ))

(def: (local_int instruction)
  (-> /.Local_Int Inst)
  (case instruction
    {/.#ILOAD register} (_.ILOAD register)
    {/.#ISTORE register} (_.ISTORE register)))

(def: (local_long instruction)
  (-> /.Local_Long Inst)
  (case instruction
    {/.#LLOAD register} (_.LLOAD register)
    {/.#LSTORE register} (_.LSTORE register)))

(def: (local_float instruction)
  (-> /.Local_Float Inst)
  (case instruction
    {/.#FLOAD register} (_.FLOAD register)
    {/.#FSTORE register} (_.FSTORE register)))

(def: (local_double instruction)
  (-> /.Local_Double Inst)
  (case instruction
    {/.#DLOAD register} (_.DLOAD register)
    {/.#DSTORE register} (_.DSTORE register)))

(def: (local_object instruction)
  (-> /.Local_Object Inst)
  (case instruction
    {/.#ALOAD register} (_.ALOAD register)
    {/.#ASTORE register} (_.ASTORE register)))

(def: (local instruction)
  (-> /.Local Inst)
  (case instruction
    {/.#Local_Int instruction} (..local_int instruction)
    {/.#IINC register} (_.IINC register)
    {/.#Local_Long instruction} (..local_long instruction)
    {/.#Local_Float instruction} (..local_float instruction)
    {/.#Local_Double instruction} (..local_double instruction)
    {/.#Local_Object instruction} (..local_object instruction)))

(def: (stack instruction)
  (-> /.Stack Inst)
  (case instruction
    {/.#DUP} _.DUP
    {/.#DUP_X1} _.DUP_X1
    {/.#DUP_X2} _.DUP_X2
    {/.#DUP2} _.DUP2
    {/.#DUP2_X1} _.DUP2_X1
    {/.#DUP2_X2} _.DUP2_X2
    {/.#SWAP} _.SWAP
    {/.#POP} _.POP
    {/.#POP2} _.POP2))

(def: (comparison instruction)
  (-> /.Comparison Inst)
  (case instruction
    {/.#LCMP} _.LCMP
    
    {/.#FCMPG} _.FCMPG
    {/.#FCMPL} _.FCMPL

    {/.#DCMPG} _.DCMPG
    {/.#DCMPL} _.DCMPL))

(def: (branching instruction)
  (-> (/.Branching org/objectweb/asm/Label) Inst)
  (case instruction
    {/.#IF_ICMPEQ label} (_.IF_ICMPEQ label)
    {/.#IF_ICMPGE label} (_.IF_ICMPGE label)
    {/.#IF_ICMPGT label} (_.IF_ICMPGT label)
    {/.#IF_ICMPLE label} (_.IF_ICMPLE label)
    {/.#IF_ICMPLT label} (_.IF_ICMPLT label)
    {/.#IF_ICMPNE label} (_.IF_ICMPNE label)
    {/.#IFEQ label} (_.IFEQ label)
    {/.#IFGE label} (_.IFGE label)
    {/.#IFGT label} (_.IFGT label)
    {/.#IFLE label} (_.IFLE label)
    {/.#IFLT label} (_.IFLT label)
    {/.#IFNE label} (_.IFNE label)

    {/.#TABLESWITCH min max default labels}
    (_.TABLESWITCH min max default labels)
    
    {/.#LOOKUPSWITCH default keys+labels}
    (_.LOOKUPSWITCH default keys+labels)

    {/.#IF_ACMPEQ label} (_.IF_ACMPEQ label)
    {/.#IF_ACMPNE label} (_.IF_ACMPNE label)
    {/.#IFNONNULL label} (_.IFNONNULL label)
    {/.#IFNULL label} (_.IFNULL label)))

(def: (exception instruction)
  (-> (/.Exception org/objectweb/asm/Label) Inst)
  (case instruction
    {/.#Try start end handler exception} (_.try start end handler exception)
    {/.#ATHROW} _.ATHROW))

(def: (concurrency instruction)
  (-> /.Concurrency Inst)
  (case instruction
    {/.#MONITORENTER} _.MONITORENTER
    {/.#MONITOREXIT} _.MONITOREXIT))

(def: (return instruction)
  (-> /.Return Inst)
  (case instruction
    {/.#RETURN} _.RETURN
    {/.#IRETURN} _.IRETURN
    {/.#LRETURN} _.LRETURN
    {/.#FRETURN} _.FRETURN
    {/.#DRETURN} _.DRETURN
    {/.#ARETURN} _.ARETURN))

(def: (control instruction)
  (-> (/.Control org/objectweb/asm/Label) Inst)
  (case instruction
    {/.#GOTO label} (_.GOTO label)
    {/.#Branching instruction} (..branching instruction)
    {/.#Exception instruction} (..exception instruction)
    {/.#Concurrency instruction} (..concurrency instruction)
    {/.#Return instruction} (..return instruction)))

(def: (instruction instruction)
  (-> (/.Instruction Inst org/objectweb/asm/Label) Inst)
  (case instruction
    {/.#NOP} _.NOP
    {/.#Constant instruction} (..constant instruction)
    {/.#Arithmetic instruction} (..arithmetic instruction)
    {/.#Bitwise instruction} (..bitwise instruction)
    {/.#Conversion instruction} (..conversion instruction)
    {/.#Array instruction} (..array instruction)
    {/.#Object instruction} (..object instruction)
    {/.#Local instruction} (..local instruction)
    {/.#Stack instruction} (..stack instruction)
    {/.#Comparison instruction} (..comparison instruction)
    {/.#Control instruction} (..control instruction)
    {/.#Embedded embedded} embedded))

(type: Mapping
  (Dictionary /.Label org/objectweb/asm/Label))

(type: (Re_labeler context)
  (-> [Mapping (context /.Label)]
      [Mapping (context org/objectweb/asm/Label)]))

(def: (relabel [mapping label])
  (Re_labeler Identity)
  (case (dictionary.value label mapping)
    {.#Some label}
    [mapping label]

    {.#None}
    (let [label' (org/objectweb/asm/Label::new)]
      [(dictionary.has label label' mapping) label'])))

(def: (relabel_branching [mapping instruction])
  (Re_labeler /.Branching)
  (case instruction
    (^template [<tag>]
      [{<tag> label}
       (let [[mapping label] (..relabel [mapping label])]
         [mapping {<tag> label}])])
    ([/.#IF_ICMPEQ] [/.#IF_ICMPGE] [/.#IF_ICMPGT] [/.#IF_ICMPLE] [/.#IF_ICMPLT] [/.#IF_ICMPNE]
     [/.#IFEQ] [/.#IFNE] [/.#IFGE] [/.#IFGT] [/.#IFLE] [/.#IFLT]

     [/.#IF_ACMPEQ] [/.#IF_ACMPNE] [/.#IFNONNULL] [/.#IFNULL])

    {/.#TABLESWITCH min max default labels}
    (let [[mapping default] (..relabel [mapping default])
          [mapping labels] (list#mix (function (_ input [mapping output])
                                       (let [[mapping input] (..relabel [mapping input])]
                                         [mapping (list& input output)]))
                                     [mapping (list)] labels)]
      [mapping {/.#TABLESWITCH min max default (list.reversed labels)}])
    
    {/.#LOOKUPSWITCH default keys+labels}
    (let [[mapping default] (..relabel [mapping default])
          [mapping keys+labels] (list#mix (function (_ [expected input] [mapping output])
                                            (let [[mapping input] (..relabel [mapping input])]
                                              [mapping (list& [expected input] output)]))
                                          [mapping (list)] keys+labels)]
      [mapping {/.#LOOKUPSWITCH default (list.reversed keys+labels)}])
    ))

(def: (relabel_exception [mapping instruction])
  (Re_labeler /.Exception)
  (case instruction
    {/.#Try start end handler exception}
    (let [[mapping start] (..relabel [mapping start])
          [mapping end] (..relabel [mapping end])
          [mapping handler] (..relabel [mapping handler])]
      [mapping {/.#Try start end handler exception}])
    
    {/.#ATHROW}
    [mapping {/.#ATHROW}]
    ))

(def: (relabel_control [mapping instruction])
  (Re_labeler /.Control)
  (case instruction
    (^template [<tag> <relabel>]
      [{<tag> instruction}
       (let [[mapping instruction] (<relabel> [mapping instruction])]
         [mapping {<tag> instruction}])])
    ([/.#GOTO ..relabel]
     [/.#Branching ..relabel_branching]
     [/.#Exception ..relabel_exception])

    (^template [<tag>]
      [{<tag> instruction}
       [mapping {<tag> instruction}]])
    ([/.#Concurrency] [/.#Return])
    ))

(def: (relabel_instruction [mapping instruction])
  (Re_labeler (/.Instruction Inst))
  (case instruction
    {/.#Embedded embedded}
    [mapping {/.#Embedded embedded}]

    {/.#NOP}
    [mapping {/.#NOP}]

    (^template [<tag>]
      [{<tag> instruction}
       [mapping {<tag> instruction}]])
    ([/.#Constant]
     [/.#Arithmetic]
     [/.#Bitwise]
     [/.#Conversion]
     [/.#Array]
     [/.#Object]
     [/.#Local]
     [/.#Stack]
     [/.#Comparison])
    
    {/.#Control instruction}
    (let [[mapping instruction] (..relabel_control [mapping instruction])]
      [mapping {/.#Control instruction}])))

(def: (relabel_bytecode [mapping bytecode])
  (Re_labeler (/.Bytecode Inst))
  (row#mix (function (_ input [mapping output])
             (let [[mapping input'] (..relabel_instruction [mapping input])]
               [mapping (row.suffix input' output)]))
           [mapping (row.row)]
           bytecode))

(def: fresh
  Mapping
  (dictionary.empty nat.hash))

(def: bytecode
  (-> (/.Bytecode Inst /.Label) jvm.Inst)
  (|>> [..fresh]
       ..relabel_bytecode
       product.right
       (row#each ..instruction)
       row.list
       _.fuse))

(with_expansions [<anchor> (as_is jvm.Anchor)
                  <expression> (as_is Inst)
                  <directive> (as_is jvm.Definition)
                  <type_vars> (as_is <anchor> <expression> <directive>)]
  (type: Handler'
    ... (generation.Handler jvm.Anchor (/.Bytecode Inst /.Label) jvm.Definition)
    (-> extension.Name
        (phase.Phase [(extension.Bundle <type_vars>)
                      (generation.State <type_vars>)]
                     Synthesis
                     <expression>)
        (phase.Phase [(extension.Bundle <type_vars>)
                      (generation.State <type_vars>)]
                     (List Synthesis)
                     (/.Bytecode Inst /.Label)))))

(def: (true_handler extender pseudo)
  (-> jvm.Extender Any jvm.Handler)
  (function (_ extension_name phase archive inputs)
    (# phase.monad each
       (|>> (:as (/.Bytecode Inst /.Label)) ..bytecode)
       ((extender pseudo) extension_name phase archive inputs))))

(type: Phase (directive.Phase jvm.Anchor jvm.Inst jvm.Definition))
(type: Operation (directive.Operation jvm.Anchor jvm.Inst jvm.Definition))
(type: Handler (directive.Handler jvm.Anchor jvm.Inst jvm.Definition))

(def: (def::generation extender)
  (-> jvm.Extender ..Handler)
  (function (handler extension_name phase archive inputsC+)
    (case inputsC+
      (^ (list nameC valueC))
      (do phase.monad
        [[_ _ name] (lux/.evaluate! archive Text nameC)
         [_ handlerV] (lux/.generator archive (:as Text name) ..Handler' valueC)
         _ (|> handlerV
               (..true_handler extender)
               (extension.install extender (:as Text name))
               directive.lifted_generation)
         _ (directive.lifted_generation
            (generation.log! (format "Generation " (%.text (:as Text name)))))]
        (in directive.no_requirements))

      _
      (phase.except extension.invalid_syntax [extension_name %.code inputsC+]))))

(def: .public (custom [parser handler])
  (All (_ i)
    (-> [(Parser i)
         (-> Text ..Phase Archive i (..Operation Requirements))]
        ..Handler))
  (function (_ extension_name phase archive input)
    (case (<code>.result parser input)
      {try.#Success input'}
      (handler extension_name phase archive input')

      {try.#Failure error}
      (phase.except extension.invalid_syntax [extension_name %.code input]))))

(type: Declaration
  [External (List (Type Var))])

(template [<name> <type> <parser>]
  [(def: <name>
     (Parser <type>)
     (do [! <>.monad]
       [raw <code>.text]
       (<>.lifted (<text>.result <parser> raw))))]

  [class_declaration Declaration parser.declaration']
  [class (Type Class) parser.class]
  [type_variable (Type Var) parser.var]
  [value (Type Value) parser.value]
  [return_type (Type Return) parser.return]
  )

(type: Annotation
  Code)

(def: annotation
  (Parser Annotation)
  <code>.any)

(type: Method_Declaration
  (Record
   [#name Text
    #annotations (List Annotation)
    #type_variables (List (Type Var))
    #exceptions (List (Type Class))
    #arguments (List (Type Value))
    #return (Type Value)]))

(def: method_declaration
  (Parser Method_Declaration)
  (<code>.form
   ($_ <>.and
       <code>.text
       (<code>.tuple (<>.some ..annotation))
       (<code>.tuple (<>.some ..type_variable))
       (<code>.tuple (<>.some ..class))
       (<code>.tuple (<>.some ..value))
       ..value
       )))

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

(def: inheritance
  (Parser Inheritance)
  ($_ <>.or
      (<code>.text! "final")
      (<code>.text! "abstract")
      (<code>.text! "default")
      ))

(def: privacy
  (Parser Privacy)
  ($_ <>.or
      (<code>.text! "public")
      (<code>.text! "private")
      (<code>.text! "protected")
      (<code>.text! "default")
      ))

(def: state
  (Parser State)
  ($_ <>.or
      (<code>.text! "volatile")
      (<code>.text! "final")
      (<code>.text! "default")
      ))

(type: Field
  [Text Privacy State (List Annotation) (Type Value)])

(def: field
  (Parser Field)
  (<code>.form
   (do <>.monad
     [_ (<code>.text! "variable")
      name <code>.text
      privacy ..privacy
      state ..state
      _ (<code>.tuple (<>.some ..annotation))
      type ..value]
     (in [name privacy state (list) type]))))

(type: Argument
  [Text (Type Value)])

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

(type: (Constructor a)
  [Privacy Bit (List Annotation) (List (Type Var)) (List (Type Class))
   Text (List Argument) (List [(Type Value) a])
   a])

(type: (Override a)
  [Declaration Text Bit (List Annotation) (List (Type Var))
   Text (List Argument) (Type Return) (List (Type Class))
   a])

(type: (Virtual a)
  [Text Privacy Bit Bit (List Annotation) (List (Type Var))
   Text (List Argument) (Type Return) (List (Type Class))
   a])

(type: (Static a)
  [Text Privacy Bit (List Annotation) (List (Type Var))
   (List Argument) (Type Return) (List (Type Class))
   a])

(type: Abstract
  [Text Privacy (List Annotation) (List (Type Var))
   (List Argument) (Type Return) (List (Type Class))])

(type: (Method a)
  (Variant
   {#Constructor (Constructor a)}
   {#Override (Override a)}
   {#Virtual (Virtual a)}
   {#Static (Static a)}
   {#Abstract Abstract}))

(def: constructor
  (Parser (Constructor Code))
  (let [constructor_argument (: (Parser [(Type Value) Code])
                                (<code>.tuple
                                 (<>.and ..value
                                         <code>.any)))]
    (<| <code>.form
        (<>.after (<code>.text! "init"))
        ($_ <>.and
            ..privacy
            <code>.bit
            (<code>.tuple (<>.some ..annotation))
            (<code>.tuple (<>.some ..type_variable))
            (<code>.tuple (<>.some ..class))
            <code>.text
            (<code>.tuple (<>.some ..argument))
            (<code>.tuple (<>.some constructor_argument))
            <code>.any
            ))))

(def: override
  (Parser (Override Code))
  (<| <code>.form
      (<>.after (<code>.text! "override"))
      ($_ <>.and
          ..class_declaration
          <code>.text
          <code>.bit
          (<code>.tuple (<>.some ..annotation))
          (<code>.tuple (<>.some ..type_variable))
          <code>.text
          (<code>.tuple (<>.some ..argument))
          ..return_type
          (<code>.tuple (<>.some ..class))
          <code>.any
          )))

(def: virtual
  (Parser (Virtual Code))
  (<| <code>.form
      (<>.after (<code>.text! "virtual"))
      ($_ <>.and
          <code>.text
          ..privacy
          <code>.bit
          <code>.bit
          (<code>.tuple (<>.some ..annotation))
          (<code>.tuple (<>.some ..type_variable))
          <code>.text
          (<code>.tuple (<>.some ..argument))
          ..return_type
          (<code>.tuple (<>.some ..class))
          <code>.any
          )))

(def: static
  (Parser (Static Code))
  (<| <code>.form
      (<>.after (<code>.text! "static"))
      ($_ <>.and
          <code>.text
          ..privacy
          <code>.bit
          (<code>.tuple (<>.some ..annotation))
          (<code>.tuple (<>.some ..type_variable))
          (<code>.tuple (<>.some ..argument))
          ..return_type
          (<code>.tuple (<>.some ..class))
          <code>.any
          )))

(def: abstract
  (Parser Abstract)
  (<| <code>.form
      (<>.after (<code>.text! "abstract"))
      ($_ <>.and
          <code>.text
          ..privacy
          (<code>.tuple (<>.some ..annotation))
          (<code>.tuple (<>.some ..type_variable))
          (<code>.tuple (<>.some ..argument))
          ..return_type
          (<code>.tuple (<>.some ..class))
          )))

(def: method
  (Parser (Method Code))
  ($_ <>.or
      ..constructor
      ..override
      ..virtual
      ..static
      ..abstract
      ))

(def: (constraint tv)
  (-> (Type Var) Constraint)
  [/type.#name (parser.name tv)
   /type.#super_class java/lang/Object
   /type.#super_interfaces (list)])

(def: visibility
  (-> ffi.Privacy jvm.Visibility)
  (|>> (case> {ffi.#PublicP} {jvm.#Public}
              {ffi.#PrivateP} {jvm.#Private}
              {ffi.#ProtectedP} {jvm.#Protected}
              {ffi.#DefaultP} {jvm.#Default})))

(def: field_config
  (-> ffi.State jvm.Field_Config)
  (|>> (case> {ffi.#VolatileS} jvm.volatileF
              {ffi.#FinalS} jvm.finalF
              {ffi.#DefaultS} jvm.noneF)))

(def: (field_header [name privacy state annotations type])
  (-> Field jvm.Def)
  (def.field (..visibility privacy) (..field_config state) name type))

(def: (header_value valueT)
  (-> (Type Value) Inst)
  (case (/type.primitive? valueT)
    {.#Left classT}
    _.NULL
    
    {.#Right primitiveT}
    (cond (or (# /type.equivalence = /type.boolean primitiveT)
              (# /type.equivalence = /type.byte primitiveT)
              (# /type.equivalence = /type.short primitiveT)
              (# /type.equivalence = /type.int primitiveT)
              (# /type.equivalence = /type.char primitiveT))
          _.ICONST_0

          (# /type.equivalence = /type.long primitiveT)
          _.LCONST_0

          (# /type.equivalence = /type.float primitiveT)
          _.FCONST_0

          ... (# /type.equivalence = /type.double primitiveT)
          _.DCONST_0)))

(def: (header_return returnT)
  (-> (Type Return) Inst)
  (case (/type.void? returnT)
    {.#Right returnT}
    _.RETURN

    {.#Left valueT}
    (case (/type.primitive? valueT)
      {.#Left classT}
      (|>> (header_value classT)
           _.ARETURN)
      
      {.#Right primitiveT}
      (cond (or (# /type.equivalence = /type.boolean primitiveT)
                (# /type.equivalence = /type.byte primitiveT)
                (# /type.equivalence = /type.short primitiveT)
                (# /type.equivalence = /type.int primitiveT)
                (# /type.equivalence = /type.char primitiveT))
            (|>> (header_value primitiveT)
                 _.IRETURN)

            (# /type.equivalence = /type.long primitiveT)
            (|>> (header_value primitiveT)
                 _.LRETURN)

            (# /type.equivalence = /type.float primitiveT)
            (|>> (header_value primitiveT)
                 _.FRETURN)

            ... (# /type.equivalence = /type.double primitiveT)
            (|>> (header_value primitiveT)
                 _.DRETURN)))))

(def: constructor_name
  "<init>")

(def: (abstract_method_generation method)
  (-> Abstract jvm.Def)
  (let [[name privacy annotations variables
         arguments return exceptions] method]
    (def.abstract_method (..visibility privacy)
                         jvm.noneM
                         name
                         (/type.method [variables (list#each product.right arguments) return exceptions]))))

(def: (method_header super_class method)
  (-> (Type Class) (Method Code) jvm.Def)
  (case method
    {#Constructor [privacy strict_floating_point? annotations variables exceptions
                   self arguments constructor_arguments
                   body]}
    (let [[super_name super_vars] (parser.read_class super_class)
          init_constructor_arguments (|> constructor_arguments
                                         (list#each (|>> product.left ..header_value))
                                         _.fuse)
          super_constructorT (/type.method [(list)
                                            (list#each product.left constructor_arguments)
                                            /type.void
                                            (list)])]
      (def.method (..visibility privacy)
                  (if strict_floating_point?
                    jvm.strictM
                    jvm.noneM)
                  ..constructor_name
                  (/type.method [variables (list#each product.right arguments) /type.void exceptions])
                  (|>> (_.ALOAD 0)
                       init_constructor_arguments
                       (_.INVOKESPECIAL super_class ..constructor_name super_constructorT)
                       _.RETURN)))
    
    {#Override [[parent_name parent_variables] name strict_floating_point? annotations variables
                self arguments return exceptions
                body]}
    (def.method {jvm.#Public}
                (if strict_floating_point?
                  jvm.strictM
                  jvm.noneM)
                name
                (/type.method [variables (list#each product.right arguments) return exceptions])
                (..header_return return))

    {#Virtual [name privacy final? strict_floating_point? annotations variables
               self arguments return exceptions
               body]}
    (def.method (..visibility privacy)
                (|> jvm.noneM
                    (jvm.++M (if strict_floating_point?
                               jvm.strictM
                               jvm.noneM))
                    (jvm.++M (if final?
                               jvm.finalM
                               jvm.noneM)))
                name
                (/type.method [variables (list#each product.right arguments) return exceptions])
                (..header_return return))

    {#Static [name privacy strict_floating_point? annotations variables
              arguments return exceptions
              body]}
    (def.method (..visibility privacy)
                (|> jvm.staticM
                    (jvm.++M (if strict_floating_point?
                               jvm.strictM
                               jvm.noneM)))
                name
                (/type.method [variables (list#each product.right arguments) return exceptions])
                (..header_return return))

    {#Abstract method}
    (..abstract_method_generation method)
    ))

(def: (header [class_name type_variables]
              super_class
              super_interfaces
              inheritance
              fields
              methods)
  (-> Declaration
      (Type Class)
      (List (Type Class))
      Inheritance
      (List Field)
      (List (Method Code))
      [External Binary])
  (let [constraints (list#each ..constraint type_variables)
        field_definitions (list#each ..field_header fields)
        method_definitions (list#each (..method_header super_class) methods)
        definitions (def.fuse (list#composite field_definitions
                                              method_definitions))]
    [class_name
     (case inheritance
       {ffi.#DefaultI}
       (def.class {jvm.#V1_6} {jvm.#Public} jvm.noneC class_name constraints super_class super_interfaces
                  definitions)

       {ffi.#FinalI}
       (def.class {jvm.#V1_6} {jvm.#Public} jvm.finalC class_name constraints super_class super_interfaces
                  definitions)

       {ffi.#AbstractI}
       (def.abstract {jvm.#V1_6} {jvm.#Public} jvm.noneC class_name constraints super_class super_interfaces
                     definitions))]))

(def: (constructor_method_analysis archive [class_name class_tvars] method)
  (-> Archive Declaration (Constructor Code) (Operation (Constructor Analysis)))
  (do [! phase.monad]
    [.let [[privacy strict_floating_point? annotations method_tvars exceptions
            self arguments constructor_argumentsC
            bodyC] method]
     analyse directive.analysis]
    (directive.lifted_analysis
     (do !
       [mapping (//A.with_fresh_type_vars class_tvars luxT.fresh)
        mapping (//A.with_fresh_type_vars method_tvars mapping)
        constructor_argumentsA (monad.each ! (function (_ [typeJ termC])
                                               (do !
                                                 [typeL (//A.reflection_type mapping typeJ)
                                                  termA (typeA.with_type typeL
                                                          (analyse archive termC))]
                                                 (in [typeJ termA])))
                                           constructor_argumentsC)
        selfT (//A.reflection_type mapping (/type.class class_name class_tvars))
        arguments' (monad.each !
                               (function (_ [name type])
                                 (# ! each (|>> [name])
                                    (//A.boxed_reflection_type mapping type)))
                               arguments)
        returnT (//A.boxed_reflection_return mapping /type.void)
        [_scope bodyA] (|> arguments'
                           {.#Item [self selfT]}
                           list.reversed
                           (list#mix scopeA.with_local (analyse archive bodyC))
                           (typeA.with_type returnT)
                           analysis.with_scope)]
       (in [privacy strict_floating_point? annotations method_tvars exceptions
            self arguments constructor_argumentsA
            bodyA])))))

(def: (override_method_analysis archive [class_name class_tvars] supers method)
  (-> Archive Declaration (List (Type Class)) (Override Code) (Operation (Override Analysis)))
  (do [! phase.monad]
    [.let [[[super_name super_tvars] method_name strict_floating_point? annotations
            method_tvars self arguments returnJ exceptionsJ
            bodyC] method]
     analyse directive.analysis]
    (directive.lifted_analysis
     (do !
       [mapping (//A.with_fresh_type_vars class_tvars luxT.fresh)
        .let [parent_type (/type.class super_name super_tvars)]
        mapping (//A.with_override_mapping supers parent_type mapping)
        mapping (//A.with_fresh_type_vars method_tvars mapping)
        selfT (//A.reflection_type mapping (/type.class class_name class_tvars))
        arguments' (monad.each !
                               (function (_ [name type])
                                 (# ! each (|>> [name])
                                    (//A.boxed_reflection_type mapping type)))
                               arguments)
        returnT (//A.boxed_reflection_return mapping returnJ)
        [_scope bodyA] (|> arguments'
                           {.#Item [self selfT]}
                           list.reversed
                           (list#mix scopeA.with_local (analyse archive bodyC))
                           (typeA.with_type returnT)
                           analysis.with_scope)]
       (in [[super_name super_tvars] method_name strict_floating_point? annotations
            method_tvars self arguments returnJ exceptionsJ
            bodyA])))))

(def: (virtual_method_analysis archive [class_name class_tvars] method)
  (-> Archive Declaration (Virtual Code) (Operation (Virtual Analysis)))
  (do [! phase.monad]
    [.let [[name privacy final? strict_floating_point? annotations method_tvars
            self arguments returnJ exceptionsJ
            bodyC] method]
     analyse directive.analysis]
    (directive.lifted_analysis
     (do !
       [mapping (//A.with_fresh_type_vars class_tvars luxT.fresh)
        mapping (//A.with_fresh_type_vars method_tvars mapping)
        selfT (//A.reflection_type mapping (/type.class class_name class_tvars))
        arguments' (monad.each !
                               (function (_ [name type])
                                 (# ! each (|>> [name])
                                    (//A.boxed_reflection_type mapping type)))
                               arguments)
        returnT (//A.boxed_reflection_return mapping returnJ)
        [_scope bodyA] (|> arguments'
                           {.#Item [self selfT]}
                           list.reversed
                           (list#mix scopeA.with_local (analyse archive bodyC))
                           (typeA.with_type returnT)
                           analysis.with_scope)]
       (in [name privacy final? strict_floating_point? annotations method_tvars
            self arguments returnJ exceptionsJ
            bodyA])))))

(def: (static_method_analysis archive method)
  (-> Archive (Static Code) (Operation (Static Analysis)))
  (do [! phase.monad]
    [.let [[name privacy strict_floating_point? annotations method_tvars
            arguments returnJ exceptionsJ
            bodyC] method]
     analyse directive.analysis]
    (directive.lifted_analysis
     (do !
       [mapping (//A.with_fresh_type_vars method_tvars luxT.fresh)
        arguments' (monad.each !
                               (function (_ [name type])
                                 (# ! each (|>> [name])
                                    (//A.boxed_reflection_type mapping type)))
                               arguments)
        returnT (//A.boxed_reflection_return mapping returnJ)
        [_scope bodyA] (|> arguments'
                           list.reversed
                           (list#mix scopeA.with_local (analyse archive bodyC))
                           (typeA.with_type returnT)
                           analysis.with_scope)]
       (in [name privacy strict_floating_point? annotations method_tvars
            arguments returnJ exceptionsJ
            bodyA])))))

(def: (method_analysis archive declaration supers method)
  (-> Archive Declaration (List (Type Class)) (Method Code) (Operation (Method Analysis)))
  (case method
    {#Constructor method}
    (# phase.monad each (|>> {#Constructor})
       (constructor_method_analysis archive declaration method))
    
    {#Override method}
    (# phase.monad each (|>> {#Override})
       (override_method_analysis archive declaration supers method))

    {#Virtual method}
    (# phase.monad each (|>> {#Virtual})
       (virtual_method_analysis archive declaration method))

    {#Static method}
    (# phase.monad each (|>> {#Static})
       (static_method_analysis archive method))

    {#Abstract method}
    (# phase.monad in {#Abstract method})
    ))

(template: (method_body <bodyS>)
  [(<| synthesis.function/abstraction [_ _]
       synthesis.loop/scope [_ _]
       synthesis.tuple
       (list _)
       <bodyS>)])

(def: (constructor_method_synthesis archive method)
  (-> Archive (Constructor Analysis) (Operation (Constructor Synthesis)))
  (do [! phase.monad]
    [.let [[privacy strict_floating_point? annotations method_tvars exceptions
            self arguments constructor_argumentsA
            bodyA] method]
     synthesise directive.synthesis]
    (directive.lifted_synthesis
     (do !
       [constructor_argumentsS (monad.each ! (function (_ [typeJ termA])
                                               (# ! each (|>> [typeJ])
                                                  (synthesise archive termA)))
                                           constructor_argumentsA)
        bodyS (synthesise archive {analysis.#Function (list) (//A.hide_method_body (list.size arguments) bodyA)})]
       (in [privacy strict_floating_point? annotations method_tvars exceptions
            self arguments constructor_argumentsS
            (case bodyS
              (^ (method_body bodyS))
              bodyS

              _
              bodyS)])))))

(def: (override_method_synthesis archive method)
  (-> Archive (Override Analysis) (Operation (Override Synthesis)))
  (do [! phase.monad]
    [.let [[[super_name super_tvars] method_name strict_floating_point? annotations
            method_tvars self arguments returnJ exceptionsJ
            bodyA] method]
     synthesise directive.synthesis]
    (directive.lifted_synthesis
     (do !
       [bodyS (synthesise archive {analysis.#Function (list) (//A.hide_method_body (list.size arguments) bodyA)})]
       (in [[super_name super_tvars] method_name strict_floating_point? annotations
            method_tvars self arguments returnJ exceptionsJ
            (case bodyS
              (^ (method_body bodyS))
              bodyS

              _
              bodyS)])))))

(def: (virtual_method_synthesis archive method)
  (-> Archive (Virtual Analysis) (Operation (Virtual Synthesis)))
  (do [! phase.monad]
    [.let [[name privacy final? strict_floating_point? annotations method_tvars
            self arguments returnJ exceptionsJ
            bodyA] method]
     synthesise directive.synthesis]
    (directive.lifted_synthesis
     (do !
       [bodyS (synthesise archive {analysis.#Function (list) (//A.hide_method_body (list.size arguments) bodyA)})]
       (in [name privacy final? strict_floating_point? annotations method_tvars
            self arguments returnJ exceptionsJ
            (case bodyS
              (^ (method_body bodyS))
              bodyS

              _
              bodyS)])))))

(def: (static_method_synthesis archive method)
  (-> Archive (Static Analysis) (Operation (Static Synthesis)))
  (do [! phase.monad]
    [.let [[name privacy strict_floating_point? annotations method_tvars
            arguments returnJ exceptionsJ
            bodyA] method]
     synthesise directive.synthesis]
    (directive.lifted_synthesis
     (do !
       [bodyS (synthesise archive {analysis.#Function (list) (//A.hide_method_body (list.size arguments) bodyA)})]
       (in [name privacy strict_floating_point? annotations method_tvars
            arguments returnJ exceptionsJ
            (case bodyS
              (^ (method_body bodyS))
              bodyS

              _
              bodyS)])))))

(def: (method_synthesis archive method)
  (-> Archive (Method Analysis) (Operation (Method Synthesis)))
  (case method
    {#Constructor method}
    (# phase.monad each (|>> {#Constructor})
       (constructor_method_synthesis archive method))
    
    {#Override method}
    (# phase.monad each (|>> {#Override})
       (override_method_synthesis archive method))
    
    {#Virtual method}
    (# phase.monad each (|>> {#Virtual})
       (virtual_method_synthesis archive method))
    
    {#Static method}
    (# phase.monad each (|>> {#Static})
       (static_method_synthesis archive method))

    {#Abstract method}
    (# phase.monad in {#Abstract method})
    ))

(def: (constructor_method_generation archive super_class method)
  (-> Archive (Type Class) (Constructor Synthesis) (Operation jvm.Def))
  (do [! phase.monad]
    [.let [[privacy strict_floating_point? annotations method_tvars exceptions
            self arguments constructor_argumentsS
            bodyS] method]
     generate directive.generation]
    (directive.lifted_generation
     (do !
       [constructor_argumentsG (monad.each ! (|>> product.right (generate archive))
                                           constructor_argumentsS)
        bodyG (generate archive (//G.hidden_method_body (list.size arguments) bodyS))
        .let [[super_name super_vars] (parser.read_class super_class)
              super_constructor_argument_values (_.fuse constructor_argumentsG)
              super_constructorT (/type.method [(list)
                                                (list#each product.left constructor_argumentsS)
                                                /type.void
                                                (list)])
              argumentsT (list#each product.right arguments)
              initialize_object! (: Inst
                                    (|>> (_.ALOAD 0)
                                         super_constructor_argument_values
                                         (_.INVOKESPECIAL super_class ..constructor_name super_constructorT)))]]
       (in (def.method (..visibility privacy)
                       (if strict_floating_point?
                         jvm.strictM
                         jvm.noneM)
                       ..constructor_name
                       (/type.method [method_tvars argumentsT /type.void exceptions])
                       (|>> initialize_object!
                            (//G.prepare_arguments 1 argumentsT)
                            bodyG
                            _.RETURN)))))))

(def: (override_method_generation archive method)
  (-> Archive (Override Synthesis) (Operation jvm.Def))
  (do [! phase.monad]
    [.let [[[super_name super_tvars] method_name strict_floating_point? annotations
            method_tvars self arguments returnJ exceptionsJ
            bodyS] method]
     generate directive.generation]
    (directive.lifted_generation
     (do !
       [bodyG (generate archive (//G.hidden_method_body (list.size arguments) bodyS))
        .let [argumentsT (list#each product.right arguments)]]
       (in (def.method {jvm.#Public}
                       (if strict_floating_point?
                         jvm.strictM
                         jvm.noneM)
                       method_name
                       (/type.method [method_tvars argumentsT returnJ exceptionsJ])
                       (|>> (//G.prepare_arguments 1 argumentsT)
                            bodyG
                            (//G.returnI returnJ))))))))

(def: (virtual_method_generation archive method)
  (-> Archive (Virtual Synthesis) (Operation jvm.Def))
  (do [! phase.monad]
    [.let [[method_name privacy final? strict_floating_point? annotations method_tvars
            self arguments returnJ exceptionsJ
            bodyS] method]
     generate directive.generation]
    (directive.lifted_generation
     (do !
       [bodyG (generate archive (//G.hidden_method_body (list.size arguments) bodyS))
        .let [argumentsT (list#each product.right arguments)]]
       (in (def.method (..visibility privacy)
                       (|> jvm.noneM
                           (jvm.++M (if strict_floating_point?
                                      jvm.strictM
                                      jvm.noneM))
                           (jvm.++M (if final?
                                      jvm.finalM
                                      jvm.noneM)))
                       method_name
                       (/type.method [method_tvars argumentsT returnJ exceptionsJ])
                       (|>> (//G.prepare_arguments 1 argumentsT)
                            bodyG
                            (//G.returnI returnJ))))))))

(def: (static_method_generation archive method)
  (-> Archive (Static Synthesis) (Operation jvm.Def))
  (do [! phase.monad]
    [.let [[method_name privacy strict_floating_point? annotations method_tvars
            arguments returnJ exceptionsJ
            bodyS] method]
     generate directive.generation]
    (directive.lifted_generation
     (do !
       [bodyG (generate archive (//G.hidden_method_body (list.size arguments) bodyS))
        .let [argumentsT (list#each product.right arguments)]]
       (in (def.method (..visibility privacy)
                       (|> jvm.staticM
                           (jvm.++M (if strict_floating_point?
                                      jvm.strictM
                                      jvm.noneM)))
                       method_name
                       (/type.method [method_tvars argumentsT returnJ exceptionsJ])
                       (|>> (//G.prepare_arguments 0 argumentsT)
                            bodyG
                            (//G.returnI returnJ))))))))

(def: (method_generation archive super_class method)
  (-> Archive (Type Class) (Method Synthesis) (Operation jvm.Def))
  (case method
    {#Constructor method}
    (..constructor_method_generation archive super_class method)
    
    {#Override method}
    (..override_method_generation archive method)
    
    {#Virtual method}
    (..virtual_method_generation archive method)
    
    {#Static method}
    (..static_method_generation archive method)

    {#Abstract method}
    (# phase.monad in (..abstract_method_generation method))
    ))

(import: java/lang/ClassLoader)

(def: (convert_overriden_method method)
  (-> (Method Code) (Maybe (//A.Overriden_Method Code)))
  (case method
    {#Override [[parent_name parent_variables] method_name strict_floating_point? annotations variables
                self arguments return exceptions
                body]}
    {.#Some [(/type.class parent_name parent_variables) method_name
             strict_floating_point? (list) variables
             self arguments return exceptions
             body]}

    _
    {.#None}))

(def: (jvm::class class_loader)
  (-> java/lang/ClassLoader ..Handler)
  (..custom
   [($_ <>.and
        ..class_declaration
        ..class
        (<code>.tuple (<>.some ..class))
        ..inheritance
        (<code>.tuple (<>.some ..annotation))
        (<code>.tuple (<>.some ..field))
        (<code>.tuple (<>.some ..method)))
    (function (_ extension_name phase archive
                 [declaration
                  super_class
                  super_interfaces
                  inheritance
                  annotations
                  fields
                  methodsC])
      (do [! phase.monad]
        [.let [[class_name type_variables] declaration
               header (..header [class_name type_variables]
                                super_class
                                super_interfaces
                                inheritance
                                fields
                                methodsC)]
         ... Necessary for reflection to work properly during analysis.
         _ (directive.lifted_generation
            (generation.execute! header))
         .let [supers (: (List (Type Class))
                         (list& super_class super_interfaces))]
         _ (|> methodsC
               (list.all ..convert_overriden_method)
               (//A.require_complete_method_concretion class_loader supers)
               directive.lifted_analysis)
         methodsA (monad.each ! (method_analysis archive declaration supers) methodsC)
         methodsS (monad.each ! (method_synthesis archive) methodsA)
         methodsG (monad.each ! (method_generation archive super_class) methodsS)
         .let [directive [class_name
                          (def.class {jvm.#V1_6} {jvm.#Public} jvm.noneC class_name
                                     (list#each ..constraint type_variables)
                                     super_class
                                     super_interfaces
                                     (def.fuse (list#composite (list#each ..field_header fields)
                                                               methodsG)))]]]
        (directive.lifted_generation
         (do !
           [artifact_id (generation.learn_custom class_name)
            _ (generation.execute! directive)
            _ (generation.save! artifact_id {.#Some class_name} directive)
            _ (generation.log! (format "JVM Class " (%.text class_name)))]
           (in directive.no_requirements)))))]))

(def: jvm::class::interface
  ..Handler
  (..custom
   [($_ <>.and
        ..class_declaration
        (<code>.tuple (<>.some ..class))
        (<code>.tuple (<>.some ..annotation))
        (<>.some ..method_declaration))
    (function (_ extension_name phase archive [[class_name type_variables] supers annotations method_declarations])
      (do [! phase.monad]
        [.let [directive [class_name
                          (def.interface {jvm.#V1_6} {jvm.#Public} jvm.noneC class_name
                                         (list#each ..constraint type_variables)
                                         supers
                                         (|> method_declarations
                                             (list#each (function (_ (^open "_[0]"))
                                                          (def.abstract_method {jvm.#Public} jvm.noneM _#name
                                                                               (/type.method [_#type_variables _#arguments _#return _#exceptions]))))
                                             def.fuse))]]]
        (directive.lifted_generation
         (do !
           [artifact_id (generation.learn_custom class_name)
            _ (generation.execute! directive)
            _ (generation.save! artifact_id {.#Some class_name} directive)
            _ (generation.log! (format "JVM Interface " (%.text class_name)))]
           (in directive.no_requirements)))))]))

(def: .public (bundle class_loader extender)
  (-> java/lang/ClassLoader jvm.Extender (directive.Bundle jvm.Anchor jvm.Inst jvm.Definition))
  (|> bundle.empty
      (dictionary.has "lux def generation" (..def::generation extender))
      (dictionary.has "jvm class" (..jvm::class class_loader))
      (dictionary.has "jvm class interface" ..jvm::class::interface)))