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

(.module:
  [library
   [lux {"-" [Type 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 (_ (^slots [#name #annotations #type_variables #exceptions #arguments #return]))
                                                          (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)))