(.using
 [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]" sequence {"+" Sequence} ("[1]#[0]" functor mix)]
     ["[0]" set {"+" Set}]]]
   [math
    [number
     ["[0]" nat]]]
   [target
    ["/" jvm
     [encoding
      ["[0]" name {"+" External}]]
     ["[1][0]" type {"+" Type Typed 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]" synthesis {"+" Synthesis}]
       ["[0]" generation]
       ["[0]" directive {"+" Requirements}]
       ["[0]" analysis {"+" Analysis}
        ["[0]A" type]]
       [phase
        [analysis
         ["[0]A" scope]]
        ["[0]" extension
         ["[0]" bundle]
         [analysis
          ["//A" jvm]]
         [directive
          ["[0]/" lux]]]]]]
     [meta
      [archive {"+" Archive}
       ["[0]" unit]]
      ["[0]" cache "_"
       ["[1]" artifact]]]]]]]
 [///
  [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))
...   (sequence#mix (function (_ input [mapping output])
...                   (let [[mapping input'] (..relabel_instruction [mapping input])]
...                     [mapping (sequence.suffix input' output)]))
...                 [mapping (sequence.sequence)]
...                 bytecode))

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

... (def: bytecode
...   (-> (/.Bytecode Inst /.Label) jvm.Inst)
...   (|>> [..fresh]
...        ..relabel_bytecode
...        product.right
...        (sequence#each ..instruction)
...        sequence.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 (Typed 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: (method_dependencies archive method)
  (-> Archive (Method Synthesis)
      (generation.Operation jvm.Anchor jvm.Inst jvm.Definition
                            (Set unit.ID)))
  (case method
    {#Constructor [privacy strict_floating_point? annotations variables exceptions
                   self arguments constructor_arguments
                   body]}
    (do [! phase.monad]
      [all_super_ctor_dependencies (monad.each ! (|>> product.right (cache.dependencies archive))
                                               constructor_arguments)
       body_dependencies (cache.dependencies archive body)]
      (in (cache.all (list& body_dependencies all_super_ctor_dependencies))))
    
    
    (^or {#Override [[parent_name parent_variables] name strict_floating_point? annotations variables
                     self arguments return exceptions
                     body]}
         {#Virtual [name privacy final? strict_floating_point? annotations variables
                    self arguments return exceptions
                    body]}
         {#Static [name privacy strict_floating_point? annotations variables
                   arguments return exceptions
                   body]})
    (cache.dependencies archive body)
    
    {#Abstract _}
    (# phase.monad in unit.none)))

(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.expecting 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.expecting 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.expecting 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.expecting 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.expecting 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.hidden_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.hidden_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.hidden_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.hidden_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)
         all_dependencies (|> methodsS
                              (monad.each ! (method_dependencies archive))
                              (# ! each cache.all)
                              directive.lifted_generation)
         .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 all_dependencies)
            _ (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 unit.none)
            _ (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)))