path: root/stdlib/source/library/lux/ffi.jvm.lux

(.module:
  [library
   ["." lux (#- Type type int char :as)
    ["#_." type ("#\." equivalence)]
    [abstract
     ["." monad (#+ Monad do)]
     ["." enum]]
    [control
     ["." function]
     ["." io]
     ["." maybe]
     ["." try (#+ Try)]
     ["." exception (#+ Exception exception:)]
     ["<>" parser ("#\." monad)
      ["<.>" code (#+ Parser)]]]
    [data
     ["." product]
     ["." text ("#\." equivalence)
      ["%" format (#+ format)]]
     [collection
      ["." array]
      ["." list ("#\." monad mix monoid)]
      ["." dictionary (#+ Dictionary)]]]
    [macro (#+ with_identifiers)
     [syntax (#+ syntax:)]
     ["." code]
     ["." template]]
    ["." meta
     ["." annotation]]
    [target
     [jvm
      [encoding
       ["." name (#+ External)]]
      ["." type (#+ Type Argument Typed)
       ["." category (#+ Void Value' Value Return' Return Method Primitive Object Class Array Var Parameter Declaration)]
       ["." box]
       ["." descriptor]
       ["." signature]
       ["." reflection]
       ["." parser]]]]]])

(def: internal
  (-> External Text)
  (|>> name.internal
       name.read))

(def: signature
  (All (_ category)
    (-> (Type category) Text))
  (|>> type.signature signature.signature))

(def: reflection
  (All (_ category)
    (-> (Type (<| Return' Value' category)) Text))
  (|>> type.reflection reflection.reflection))

(template [<name> <class>]
  [(`` (def: .public <name>
         .Type
         (#.Primitive <class> #.End)))]

  [Boolean   box.boolean]
  [Byte      box.byte]
  [Short     box.short]
  [Integer   box.int]
  [Long      box.long]
  [Float     box.float]
  [Double    box.double]
  [Character box.char]
  )

(template [<name> <class>]
  [(`` (def: .public <name>
         .Type
         (#.Primitive (reflection.reflection <class>) #.End)))]

  ... Primitives
  [boolean   reflection.boolean]
  [byte      reflection.byte]
  [short     reflection.short]
  [int       reflection.int]
  [long      reflection.long]
  [float     reflection.float]
  [double    reflection.double]
  [char      reflection.char]
  )

(def: (get_static_field class field)
  (-> Text Text Code)
  (` ("jvm member get static"
      (~ (code.text class))
      (~ (code.text field)))))

(def: (get_virtual_field class field object)
  (-> Text Text Code Code)
  (` ("jvm member get virtual"
      (~ (code.text class))
      (~ (code.text field))
      (~ object))))

(def: boxes
  (Dictionary (Type Value) Text)
  (|> (list [type.boolean box.boolean]
            [type.byte    box.byte]
            [type.short   box.short]
            [type.int     box.int]
            [type.long    box.long]
            [type.float   box.float]
            [type.double  box.double]
            [type.char    box.char])
      (dictionary.of_list type.hash)))

(template [<name> <pre> <post>]
  [(def: (<name> unboxed boxed raw)
     (-> (Type Value) Text Code Code)
     (let [unboxed (..reflection unboxed)]
       (` (|> (~ raw)
              (: (primitive (~ (code.text <pre>))))
              "jvm object cast"
              (: (primitive (~ (code.text <post>))))))))]

  [unbox boxed unboxed]
  [box unboxed boxed]
  )

(template [<name> <op> <from> <to>]
  [(template: .public (<name> value)
     [(|> value
          (: <from>)
          "jvm object cast"
          <op>
          "jvm object cast"
          (: <to>))])]

  [byte_to_long    "jvm conversion byte-to-long"    ..Byte      ..Long]

  [short_to_long   "jvm conversion short-to-long"   ..Short     ..Long]
  
  [double_to_int   "jvm conversion double-to-int"   ..Double    ..Integer]
  [double_to_long  "jvm conversion double-to-long"  ..Double    ..Long]
  [double_to_float "jvm conversion double-to-float" ..Double    ..Float]

  [float_to_int    "jvm conversion float-to-int"    ..Float     ..Integer]
  [float_to_long   "jvm conversion float-to-long"   ..Float     ..Long]
  [float_to_double "jvm conversion float-to-double" ..Float     ..Double]
  
  [int_to_byte     "jvm conversion int-to-byte"     ..Integer   ..Byte]
  [int_to_short    "jvm conversion int-to-short"    ..Integer   ..Short]
  [int_to_long     "jvm conversion int-to-long"     ..Integer   ..Long]
  [int_to_float    "jvm conversion int-to-float"    ..Integer   ..Float]
  [int_to_double   "jvm conversion int-to-double"   ..Integer   ..Double]
  [int_to_char     "jvm conversion int-to-char"     ..Integer   ..Character]

  [long_to_byte    "jvm conversion long-to-byte"    ..Long      ..Byte]
  [long_to_short   "jvm conversion long-to-short"   ..Long      ..Short]
  [long_to_int     "jvm conversion long-to-int"     ..Long      ..Integer]
  [long_to_float   "jvm conversion long-to-float"   ..Long      ..Float]
  [long_to_double  "jvm conversion long-to-double"  ..Long      ..Double]

  [char_to_byte    "jvm conversion char-to-byte"    ..Character ..Byte]
  [char_to_short   "jvm conversion char-to-short"   ..Character ..Short]
  [char_to_int     "jvm conversion char-to-int"     ..Character ..Integer]
  [char_to_long    "jvm conversion char-to-long"    ..Character ..Long]
  )

(template [<name> <from> <to> <0> <1>]
  [(template: .public (<name> value)
     [(|> value <0> <1>)])]

  [long_to_char ..Long ..Character ..long_to_int ..int_to_char]
  [byte_to_int ..Byte ..Integer ..byte_to_long ..long_to_int]
  [short_to_int ..Short ..Integer ..short_to_long ..long_to_int]
  [byte_to_char ..Byte ..Character ..byte_to_int ..int_to_char]
  [short_to_char ..Short ..Character ..short_to_int ..int_to_char]
  )

(def: constructor_method_name
  "<init>")

(type: Primitive_Mode
  (Variant
   #ManualPrM
   #AutoPrM))

(type: .public Privacy
  (Variant
   #PublicP
   #PrivateP
   #ProtectedP
   #DefaultP))

(type: .public State
  (Variant
   #VolatileS
   #FinalS
   #DefaultS))

(type: .public Inheritance
  (Variant
   #FinalI
   #AbstractI
   #DefaultI))

(type: Class_Kind
  (Variant
   #Class
   #Interface))

(type: StackFrame
  (primitive "java/lang/StackTraceElement"))

(type: StackTrace
  (array.Array StackFrame))

(type: Annotation_Parameter
  [Text Code])

(type: Annotation
  (Record
   {#ann_name   Text
    #ann_params (List Annotation_Parameter)}))

(type: Member_Declaration
  (Record
   {#member_name Text
    #member_privacy Privacy
    #member_anns (List Annotation)}))

(type: FieldDecl
  (Variant
   (#ConstantField (Type Value) Code)
   (#VariableField State (Type Value))))

(type: MethodDecl
  (Record
   {#method_tvars  (List (Type Var))
    #method_inputs (List (Type Value))
    #method_output (Type Return)
    #method_exs    (List (Type Class))}))

(type: Method_Definition
  (Variant
   (#ConstructorMethod [Bit
                        (List (Type Var))
                        Text
                        (List Argument)
                        (List (Typed Code))
                        Code
                        (List (Type Class))])
   (#VirtualMethod [Bit
                    Bit
                    (List (Type Var))
                    Text
                    (List Argument)
                    (Type Return)
                    Code
                    (List (Type Class))])
   (#OverridenMethod [Bit
                      (Type Declaration)
                      (List (Type Var))
                      Text
                      (List Argument)
                      (Type Return)
                      Code
                      (List (Type Class))])
   (#StaticMethod [Bit
                   (List (Type Var))
                   (List Argument)
                   (Type Return)
                   Code
                   (List (Type Class))])
   (#AbstractMethod [(List (Type Var))
                     (List Argument)
                     (Type Return)
                     (List (Type Class))])
   (#NativeMethod [(List (Type Var))
                   (List Argument)
                   (Type Return)
                   (List (Type Class))])))

(type: Partial_Call
  (Record
   {#pc_method Name
    #pc_args   (List Code)}))

(type: ImportMethodKind
  (Variant
   #StaticIMK
   #VirtualIMK))

(type: ImportMethodCommons
  (Record
   {#import_member_mode   Primitive_Mode
    #import_member_alias  Text
    #import_member_kind   ImportMethodKind
    #import_member_tvars  (List (Type Var))
    #import_member_args   (List [Bit (Type Value)])
    #import_member_maybe? Bit
    #import_member_try?   Bit
    #import_member_io?    Bit}))

(type: ImportConstructorDecl
  (Record{}))

(type: ImportMethodDecl
  (Record
   {#import_method_name    Text
    #import_method_return  (Type Return)}))

(type: ImportFieldDecl
  (Record
   {#import_field_mode    Primitive_Mode
    #import_field_name    Text
    #import_field_static? Bit
    #import_field_maybe?  Bit
    #import_field_setter? Bit
    #import_field_type    (Type Value)}))

(type: Import_Member_Declaration
  (Variant
   (#EnumDecl        (List Text))
   (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl])
   (#MethodDecl      [ImportMethodCommons ImportMethodDecl])
   (#FieldAccessDecl ImportFieldDecl)))

(def: (primitive_type mode type)
  (-> Primitive_Mode (Type Primitive) Code)
  (case mode
    #ManualPrM
    (cond (\ type.equivalence = type.boolean type) (` ..Boolean)
          (\ type.equivalence = type.byte type) (` ..Byte)
          (\ type.equivalence = type.short type) (` ..Short)
          (\ type.equivalence = type.int type) (` ..Integer)
          (\ type.equivalence = type.long type) (` ..Long)
          (\ type.equivalence = type.float type) (` ..Float)
          (\ type.equivalence = type.double type) (` ..Double)
          (\ type.equivalence = type.char type) (` ..Character)
          ... else
          (undefined))
    
    #AutoPrM
    (cond (\ type.equivalence = type.boolean type)
          (` .Bit)
          
          (or (\ type.equivalence = type.short type)
              (\ type.equivalence = type.byte type)
              (\ type.equivalence = type.int type)
              (\ type.equivalence = type.long type))
          (` .Int)
          
          (or (\ type.equivalence = type.float type)
              (\ type.equivalence = type.double type))
          (` .Frac)

          (\ type.equivalence = type.char type)
          (` .Nat)

          ... else
          (undefined))))

(def: (parameter_type type)
  (-> (Type Parameter) Code)
  (`` (<| (~~ (template [<when> <binding> <then>]
                [(case (<when> type)
                   (#.Some <binding>)
                   <then>

                   #.None)]

                [parser.var? name (code.identifier ["" name])]
                [parser.wildcard? _ (` .Any)]
                [parser.lower? _ (` .Any)]
                [parser.upper? limit (parameter_type limit)]
                [parser.class? [name parameters]
                 (` (.primitive (~ (code.text name))
                                [(~+ (list\each parameter_type parameters))]))]))
          ... else
          (undefined)
          )))

(def: (value_type mode type)
  (-> Primitive_Mode (Type Value) Code)
  (`` (<| (~~ (template [<when> <binding> <then>]
                [(case (<when> type)
                   (#.Some <binding>)
                   <then>

                   #.None)]

                [parser.parameter? type (parameter_type type)]
                [parser.primitive? type (primitive_type mode type)]
                [parser.array? elementT (case (parser.primitive? elementT)
                                          (#.Some elementT)
                                          (` (#.Primitive (~ (code.text (..reflection (type.array elementT)))) #.End))
                                          
                                          #.None
                                          (` (#.Primitive (~ (code.text array.type_name))
                                                          (#.Item (~ (value_type mode elementT)) #.End))))]))
          (undefined)
          )))

(def: declaration_type$
  (-> (Type Declaration) Code)
  (|>> ..signature code.text))

(def: (get_const_parser class_name field_name)
  (-> Text Text (Parser Code))
  (do <>.monad
    [.let [dotted_name (format "::" field_name)]
     _ (<code>.this! (code.identifier ["" dotted_name]))]
    (in (get_static_field class_name field_name))))

(def: (get_var_parser class_name field_name self_name)
  (-> Text Text Text (Parser Code))
  (do <>.monad
    [.let [dotted_name (format "::" field_name)]
     _ (<code>.this! (code.identifier ["" dotted_name]))]
    (in (get_virtual_field class_name field_name (code.local_identifier self_name)))))

(def: (put_var_parser class_name field_name self_name)
  (-> Text Text Text (Parser Code))
  (do <>.monad
    [.let [dotted_name (format "::" field_name)]
     [_ _ value] (: (Parser [Any Any Code])
                    (<code>.form ($_ <>.and (<code>.this! (' :=)) (<code>.this! (code.identifier ["" dotted_name])) <code>.any)))]
    (in (`' ("jvm member put virtual"
             (~ (code.text class_name))
             (~ (code.text field_name))
             (~ value)
             (~ (code.local_identifier self_name)))))))

(def: (replaced f input)
  (-> (-> Code Code) Code Code)
  (case (f input)
    (^template [<tag>]
      [[meta (<tag> parts)]
       [meta (<tag> (list\each (replaced f) parts))]])
    ([#.Form]
     [#.Tuple])
    
    [meta (#.Record pairs)]
    [meta (#.Record (list\each (: (-> [Code Code] [Code Code])
                                  (function (_ [key val])
                                    [(replaced f key) (replaced f val)]))
                               pairs))]
    
    ast'
    ast'))

(def: (parser->replacer p ast)
  (-> (Parser Code) (-> Code Code))
  (case (<>.result p (list ast))
    (#.Right [#.End ast'])
    ast'

    _
    ast
    ))

(def: (field->parser class_name self_name [[field_name _ _] field])
  (-> Text Text [Member_Declaration FieldDecl] (Parser Code))
  (case field
    (#ConstantField _)
    (get_const_parser class_name field_name)
    
    (#VariableField _)
    (<>.either (get_var_parser class_name field_name self_name)
               (put_var_parser class_name field_name self_name))))

(def: (decorate_input [class value])
  (-> [(Type Value) Code] Code)
  (` [(~ (code.text (..signature class))) (~ value)]))

(def: (constructor_parser class_name arguments)
  (-> Text (List Argument) (Parser Code))
  (do <>.monad
    [args (: (Parser (List Code))
             (<code>.form (<>.after (<code>.this! (' ::new!))
                                    (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))]
    (in (` ("jvm member invoke constructor" (~ (code.text class_name))
            (~+ (|> args
                    (list.zipped/2 (list\each product.right arguments))
                    (list\each ..decorate_input))))))))

(def: (static_method_parser class_name method_name arguments)
  (-> Text Text (List Argument) (Parser Code))
  (do <>.monad
    [.let [dotted_name (format "::" method_name "!")]
     args (: (Parser (List Code))
             (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name]))
                                    (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))]
    (in (` ("jvm member invoke static" (~ (code.text class_name)) (~ (code.text method_name))
            (~+ (|> args
                    (list.zipped/2 (list\each product.right arguments))
                    (list\each ..decorate_input))))))))

(template [<name> <jvm_op>]
  [(def: (<name> class_name method_name arguments self_name)
     (-> Text Text (List Argument) Text (Parser Code))
     (do <>.monad
       [.let [dotted_name (format "::" method_name "!")]
        args (: (Parser (List Code))
                (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name]))
                                       (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))]
       (in (` (<jvm_op> (~ (code.text class_name)) (~ (code.text method_name))
                        (~ (code.local_identifier self_name))
                        (~+ (|> args
                                (list.zipped/2 (list\each product.right arguments))
                                (list\each ..decorate_input))))))))]

  [special_method_parser "jvm member invoke special"]
  [virtual_method_parser "jvm member invoke virtual"]
  )

(def: (method->parser class_name [[method_name _ _] meth_def])
  (-> Text [Member_Declaration Method_Definition] (Parser Code))
  (case meth_def
    (#ConstructorMethod strict? type_vars self_name args constructor_args return_expr exs)
    (constructor_parser class_name args)
    
    (#StaticMethod strict? type_vars args return_type return_expr exs)
    (static_method_parser class_name method_name args)

    (#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs)
    (virtual_method_parser class_name method_name args self_name)
    
    (#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs)
    (special_method_parser class_name method_name args self_name)

    (#AbstractMethod type_vars args return_type exs)
    (virtual_method_parser class_name method_name args "")

    (#NativeMethod type_vars args return_type exs)
    (virtual_method_parser class_name method_name args "")))

(def: privacy_modifier^
  (Parser Privacy)
  (let [(^open ".") <>.monad]
    ($_ <>.or
        (<code>.this! (' "public"))
        (<code>.this! (' "private"))
        (<code>.this! (' "protected"))
        (in []))))

(def: inheritance_modifier^
  (Parser Inheritance)
  (let [(^open ".") <>.monad]
    ($_ <>.or
        (<code>.this! (' "final"))
        (<code>.this! (' "abstract"))
        (in []))))

(exception: .public (class_names_cannot_contain_periods {name Text})
  (exception.report
   ["Name" (%.text name)]))

(exception: .public (class_name_cannot_be_a_type_variable {name Text}
                                                          {type_vars (List (Type Var))})
  (exception.report
   ["Name" (%.text name)]
   ["Type Variables" (exception.listing parser.name type_vars)]))

(def: (assertion exception payload test)
  (All (_ e) (-> (Exception e) e Bit (Parser Any)))
  (<>.assertion (exception.error exception payload)
                test))

(def: (valid_class_name type_vars)
  (-> (List (Type Var)) (Parser External))
  (do <>.monad
    [name <code>.local_identifier
     _ (..assertion ..class_names_cannot_contain_periods [name]
                    (not (text.contains? name.external_separator name)))
     _ (..assertion ..class_name_cannot_be_a_type_variable [name type_vars]
                    (not (list.member? text.equivalence
                                       (list\each parser.name type_vars)
                                       name)))]
    (in name)))

(def: (class^' parameter^ type_vars)
  (-> (-> (List (Type Var)) (Parser (Type Parameter)))
      (-> (List (Type Var)) (Parser (Type Class))))
  (do <>.monad
    [.let [class_name^ (..valid_class_name type_vars)]
     [name parameters] (: (Parser [External (List (Type Parameter))])
                          ($_ <>.either
                              (<>.and class_name^ (<>\in (list)))
                              (<code>.form (<>.and class_name^ (<>.some (parameter^ type_vars))))))]
    (in (type.class (name.safe name) parameters))))

(exception: .public (unexpected_type_variable {name Text}
                                              {type_vars (List (Type Var))})
  (exception.report
   ["Unexpected Type Variable" (%.text name)]
   ["Expected Type Variables" (exception.listing parser.name type_vars)]))

(def: (variable^ type_vars)
  (-> (List (Type Var)) (Parser (Type Parameter)))
  (do <>.monad
    [name <code>.local_identifier
     _ (..assertion ..unexpected_type_variable [name type_vars]
                    (list.member? text.equivalence (list\each parser.name type_vars) name))]
    (in (type.var name))))

(def: wildcard^
  (Parser (Type Parameter))
  (do <>.monad
    [_ (<code>.this! (' ?))]
    (in type.wildcard)))

(template [<name> <comparison> <constructor>]
  [(def: <name>
     (-> (Parser (Type Class)) (Parser (Type Parameter)))
     (|>> (<>.after (<code>.this! (' <comparison>)))
          (<>.after ..wildcard^)
          <code>.tuple
          (\ <>.monad each <constructor>)))]

  [upper^ < type.upper]
  [lower^ > type.lower]
  )

(def: (parameter^ type_vars)
  (-> (List (Type Var)) (Parser (Type Parameter)))
  (<>.rec
   (function (_ recur^)
     (let [class^ (..class^' parameter^ type_vars)]
       ($_ <>.either
           (..variable^ type_vars)
           ..wildcard^
           (upper^ class^)
           (lower^ class^)
           class^
           )))))

(def: (itself^ type)
  (All (_ category)
    (-> (Type (<| Return' Value' category))
        (Parser (Type (<| Return' Value' category)))))
  (do <>.monad
    [_ (<code>.identifier! ["" (..reflection type)])]
    (in type)))

(def: primitive^
  (Parser (Type Primitive))
  ($_ <>.either
      (itself^ type.boolean)
      (itself^ type.byte)
      (itself^ type.short)
      (itself^ type.int)
      (itself^ type.long)
      (itself^ type.float)
      (itself^ type.double)
      (itself^ type.char)
      ))

(def: array^
  (-> (Parser (Type Value)) (Parser (Type Array)))
  (|>> <code>.tuple
       (\ <>.monad each type.array)))

(def: (type^ type_vars)
  (-> (List (Type Var)) (Parser (Type Value)))
  (<>.rec
   (function (_ type^)
     ($_ <>.either
         ..primitive^
         (..parameter^ type_vars)
         (..array^ type^)
         ))))

(def: void^
  (Parser (Type Void))
  (do <>.monad
    [_ (<code>.identifier! ["" (reflection.reflection reflection.void)])]
    (in type.void)))

(def: (return^ type_vars)
  (-> (List (Type Var)) (Parser (Type Return)))
  (<>.either ..void^
             (..type^ type_vars)))

(def: var^
  (Parser (Type Var))
  (\ <>.monad each type.var <code>.local_identifier))

(def: vars^
  (Parser (List (Type Var)))
  (<code>.tuple (<>.some var^)))

(def: declaration^
  (Parser (Type Declaration))
  (do <>.monad
    [[name variables] (: (Parser [External (List (Type Var))])
                         (<>.either (<>.and (..valid_class_name (list))
                                            (<>\in (list)))
                                    (<code>.form (<>.and (..valid_class_name (list))
                                                         (<>.some var^)))
                                    ))]
    (in (type.declaration name variables))))

(def: (class^ type_vars)
  (-> (List (Type Var)) (Parser (Type Class)))
  (class^' parameter^ type_vars))

(def: annotation_parameters^
  (Parser (List Annotation_Parameter))
  (<code>.record (<>.some (<>.and <code>.local_tag <code>.any))))

(def: annotation^
  (Parser Annotation)
  (<>.either (do <>.monad
               [ann_name <code>.local_identifier]
               (in [ann_name (list)]))
             (<code>.form (<>.and <code>.local_identifier
                                  annotation_parameters^))))

(def: annotations^
  (Parser (List Annotation))
  (<| (<>.else (list))
      (do <>.monad
        [_ (<code>.this! (' "ann"))]
        (<code>.tuple (<>.some ..annotation^)))))

(def: (throws_decl^ type_vars)
  (-> (List (Type Var)) (Parser (List (Type Class))))
  (<| (<>.else (list))
      (do <>.monad
        [_ (<code>.this! (' "throws"))]
        (<code>.tuple (<>.some (..class^ type_vars))))))

(def: (method_decl^ type_vars)
  (-> (List (Type Var)) (Parser [Member_Declaration MethodDecl]))
  (<code>.form (do <>.monad
                 [tvars (<>.else (list) ..vars^)
                  .let [total_vars (list\composite tvars type_vars)]
                  name <code>.local_identifier
                  anns ..annotations^
                  inputs (<code>.tuple (<>.some (..type^ total_vars)))
                  output (..return^ total_vars)
                  exs (..throws_decl^ total_vars)]
                 (in [[name #PublicP anns] {#method_tvars tvars
                                            #method_inputs inputs
                                            #method_output output
                                            #method_exs exs}]))))

(def: state_modifier^
  (Parser State)
  ($_ <>.or
      (<code>.this! (' "volatile"))
      (<code>.this! (' "final"))
      (\ <>.monad in [])))

(def: (field_decl^ type_vars)
  (-> (List (Type Var)) (Parser [Member_Declaration FieldDecl]))
  (<>.either (<code>.form (do <>.monad
                            [_ (<code>.this! (' "const"))
                             name <code>.local_identifier
                             anns ..annotations^
                             type (..type^ type_vars)
                             body <code>.any]
                            (in [[name #PublicP anns] (#ConstantField [type body])])))
             (<code>.form (do <>.monad
                            [pm privacy_modifier^
                             sm state_modifier^
                             name <code>.local_identifier
                             anns ..annotations^
                             type (..type^ type_vars)]
                            (in [[name pm anns] (#VariableField [sm type])])))))

(def: (argument^ type_vars)
  (-> (List (Type Var)) (Parser Argument))
  (<code>.record (<>.and <code>.local_identifier
                         (..type^ type_vars))))

(def: (arguments^ type_vars)
  (-> (List (Type Var)) (Parser (List Argument)))
  (<>.some (..argument^ type_vars)))

(def: (constructor_arg^ type_vars)
  (-> (List (Type Var)) (Parser (Typed Code)))
  (<code>.record (<>.and (..type^ type_vars) <code>.any)))

(def: (constructor_args^ type_vars)
  (-> (List (Type Var)) (Parser (List (Typed Code))))
  (<code>.tuple (<>.some (..constructor_arg^ type_vars))))

(def: (constructor_method^ class_vars)
  (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition]))
  (<code>.form (do <>.monad
                 [pm privacy_modifier^
                  strict_fp? (<>.parses? (<code>.this! (' "strict")))
                  method_vars (<>.else (list) ..vars^)
                  .let [total_vars (list\composite class_vars method_vars)]
                  [_ self_name arguments] (<code>.form ($_ <>.and
                                                           (<code>.this! (' new))
                                                           <code>.local_identifier
                                                           (..arguments^ total_vars)))
                  constructor_args (..constructor_args^ total_vars)
                  exs (throws_decl^ total_vars)
                  annotations ..annotations^
                  body <code>.any]
                 (in [{#member_name constructor_method_name
                       #member_privacy pm
                       #member_anns annotations}
                      (#ConstructorMethod strict_fp? method_vars self_name arguments constructor_args body exs)]))))

(def: (virtual_method_def^ class_vars)
  (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition]))
  (<code>.form (do <>.monad
                 [pm privacy_modifier^
                  strict_fp? (<>.parses? (<code>.this! (' "strict")))
                  final? (<>.parses? (<code>.this! (' "final")))
                  method_vars (<>.else (list) ..vars^)
                  .let [total_vars (list\composite class_vars method_vars)]
                  [name self_name arguments] (<code>.form ($_ <>.and
                                                              <code>.local_identifier
                                                              <code>.local_identifier
                                                              (..arguments^ total_vars)))
                  return_type (..return^ total_vars)
                  exs (throws_decl^ total_vars)
                  annotations ..annotations^
                  body <code>.any]
                 (in [{#member_name name
                       #member_privacy pm
                       #member_anns annotations}
                      (#VirtualMethod final? strict_fp? method_vars self_name arguments return_type body exs)]))))

(def: overriden_method_def^
  (Parser [Member_Declaration Method_Definition])
  (<code>.form (do <>.monad
                 [strict_fp? (<>.parses? (<code>.this! (' "strict")))
                  owner_class ..declaration^
                  method_vars (<>.else (list) ..vars^)
                  .let [total_vars (list\composite (product.right (parser.declaration owner_class))
                                                   method_vars)]
                  [name self_name arguments] (<code>.form ($_ <>.and
                                                              <code>.local_identifier
                                                              <code>.local_identifier
                                                              (..arguments^ total_vars)))
                  return_type (..return^ total_vars)
                  exs (throws_decl^ total_vars)
                  annotations ..annotations^
                  body <code>.any]
                 (in [{#member_name name
                       #member_privacy #PublicP
                       #member_anns annotations}
                      (#OverridenMethod strict_fp? owner_class method_vars self_name arguments return_type body exs)]))))

(def: static_method_def^
  (Parser [Member_Declaration Method_Definition])
  (<code>.form (do <>.monad
                 [pm privacy_modifier^
                  strict_fp? (<>.parses? (<code>.this! (' "strict")))
                  _ (<code>.this! (' "static"))
                  method_vars (<>.else (list) ..vars^)
                  .let [total_vars method_vars]
                  [name arguments] (<code>.form (<>.and <code>.local_identifier
                                                        (..arguments^ total_vars)))
                  return_type (..return^ total_vars)
                  exs (throws_decl^ total_vars)
                  annotations ..annotations^
                  body <code>.any]
                 (in [{#member_name name
                       #member_privacy pm
                       #member_anns annotations}
                      (#StaticMethod strict_fp? method_vars arguments return_type body exs)]))))

(def: abstract_method_def^
  (Parser [Member_Declaration Method_Definition])
  (<code>.form (do <>.monad
                 [pm privacy_modifier^
                  _ (<code>.this! (' "abstract"))
                  method_vars (<>.else (list) ..vars^)
                  .let [total_vars method_vars]
                  [name arguments] (<code>.form (<>.and <code>.local_identifier
                                                        (..arguments^ total_vars)))
                  return_type (..return^ total_vars)
                  exs (throws_decl^ total_vars)
                  annotations ..annotations^]
                 (in [{#member_name name
                       #member_privacy pm
                       #member_anns annotations}
                      (#AbstractMethod method_vars arguments return_type exs)]))))

(def: native_method_def^
  (Parser [Member_Declaration Method_Definition])
  (<code>.form (do <>.monad
                 [pm privacy_modifier^
                  _ (<code>.this! (' "native"))
                  method_vars (<>.else (list) ..vars^)
                  .let [total_vars method_vars]
                  [name arguments] (<code>.form (<>.and <code>.local_identifier
                                                        (..arguments^ total_vars)))
                  return_type (..return^ total_vars)
                  exs (throws_decl^ total_vars)
                  annotations ..annotations^]
                 (in [{#member_name name
                       #member_privacy pm
                       #member_anns annotations}
                      (#NativeMethod method_vars arguments return_type exs)]))))

(def: (method_def^ class_vars)
  (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition]))
  ($_ <>.either
      (..constructor_method^ class_vars)
      (..virtual_method_def^ class_vars)
      ..overriden_method_def^
      ..static_method_def^
      ..abstract_method_def^
      ..native_method_def^))

(def: partial_call^
  (Parser Partial_Call)
  (<code>.form (<>.and <code>.identifier (<>.some <code>.any))))

(def: import_member_alias^
  (Parser (Maybe Text))
  (<>.maybe (do <>.monad
              [_ (<code>.this! (' "as"))]
              <code>.local_identifier)))

(def: (import_member_args^ type_vars)
  (-> (List (Type Var)) (Parser (List [Bit (Type Value)])))
  (<code>.tuple (<>.some (<>.and (<>.parses? (<code>.this! (' "?")))
                                 (..type^ type_vars)))))

(def: import_member_return_flags^
  (Parser [Bit Bit Bit])
  ($_ <>.and
      (<>.parses? (<code>.this! (' "io")))
      (<>.parses? (<code>.this! (' "try")))
      (<>.parses? (<code>.this! (' "?")))))

(def: primitive_mode^
  (Parser Primitive_Mode)
  (<>.or (<code>.this! (' "manual"))
         (<code>.this! (' "auto"))))

(def: (import_member_decl^ owner_vars)
  (-> (List (Type Var)) (Parser Import_Member_Declaration))
  ($_ <>.either
      (<code>.form (do <>.monad
                     [_ (<code>.this! (' "enum"))
                      enum_members (<>.some <code>.local_identifier)]
                     (in (#EnumDecl enum_members))))
      (<code>.form (do <>.monad
                     [tvars (<>.else (list) ..vars^)
                      _ (<code>.identifier! ["" "new"])
                      ?alias import_member_alias^
                      .let [total_vars (list\composite owner_vars tvars)]
                      ?prim_mode (<>.maybe primitive_mode^)
                      args (..import_member_args^ total_vars)
                      [io? try? maybe?] import_member_return_flags^]
                     (in (#ConstructorDecl [{#import_member_mode    (maybe.else #AutoPrM ?prim_mode)
                                             #import_member_alias   (maybe.else "new" ?alias)
                                             #import_member_kind    #VirtualIMK
                                             #import_member_tvars   tvars
                                             #import_member_args    args
                                             #import_member_maybe?  maybe?
                                             #import_member_try?    try?
                                             #import_member_io?     io?}
                                            {}]))
                     ))
      (<code>.form (do <>.monad
                     [kind (: (Parser ImportMethodKind)
                              (<>.or (<code>.this! (' "static"))
                                     (in [])))
                      tvars (<>.else (list) ..vars^)
                      name <code>.local_identifier
                      ?alias import_member_alias^
                      .let [total_vars (list\composite owner_vars tvars)]
                      ?prim_mode (<>.maybe primitive_mode^)
                      args (..import_member_args^ total_vars)
                      [io? try? maybe?] import_member_return_flags^
                      return (..return^ total_vars)]
                     (in (#MethodDecl [{#import_member_mode    (maybe.else #AutoPrM ?prim_mode)
                                        #import_member_alias   (maybe.else name ?alias)
                                        #import_member_kind    kind
                                        #import_member_tvars   tvars
                                        #import_member_args    args
                                        #import_member_maybe?  maybe?
                                        #import_member_try?    try?
                                        #import_member_io?     io?}
                                       {#import_method_name    name
                                        #import_method_return  return}]))))
      (<code>.form (do <>.monad
                     [static? (<>.parses? (<code>.this! (' "static")))
                      name <code>.local_identifier
                      ?prim_mode (<>.maybe primitive_mode^)
                      gtype (..type^ owner_vars)
                      maybe? (<>.parses? (<code>.this! (' "?")))
                      setter? (<>.parses? (<code>.this! (' #!)))]
                     (in (#FieldAccessDecl {#import_field_mode    (maybe.else #AutoPrM ?prim_mode)
                                            #import_field_name    name
                                            #import_field_static? static?
                                            #import_field_maybe?  maybe?
                                            #import_field_setter? setter?
                                            #import_field_type    gtype}))))
      ))

(def: bundle
  (-> (List (Type Var)) (Parser [Text (List Import_Member_Declaration)]))
  (|>> ..import_member_decl^
       <>.some
       (<>.and <code>.text)
       <code>.tuple))

(def: (privacy_modifier$ pm)
  (-> Privacy Code)
  (case pm
    #PublicP    (code.text "public")
    #PrivateP   (code.text "private")
    #ProtectedP (code.text "protected")
    #DefaultP   (code.text "default")))

(def: (inheritance_modifier$ im)
  (-> Inheritance Code)
  (case im
    #FinalI    (code.text "final")
    #AbstractI (code.text "abstract")
    #DefaultI  (code.text "default")))

(def: (annotation_parameter$ [name value])
  (-> Annotation_Parameter Code)
  (` [(~ (code.text name)) (~ value)]))

(def: (annotation$ [name params])
  (-> Annotation Code)
  (` ((~ (code.text name)) (~+ (list\each annotation_parameter$ params)))))

(template [<name> <category>]
  [(def: <name>
     (-> (Type <category>) Code)
     (|>> ..signature code.text))]

  [var$ Var]
  [parameter$ Parameter]
  [value$ Value]
  [return$ Return]
  [declaration$ Declaration]
  [class$ Class]
  )

(def: var$'
  (-> (Type Var) Code)
  (|>> ..signature code.local_identifier))

(def: (method_decl$ [[name pm anns] method_decl])
  (-> [Member_Declaration MethodDecl] Code)
  (let [(^slots [#method_tvars #method_inputs #method_output #method_exs]) method_decl]
    (` ((~ (code.text name))
        [(~+ (list\each annotation$ anns))]
        [(~+ (list\each var$ method_tvars))]
        [(~+ (list\each class$ method_exs))]
        [(~+ (list\each value$ method_inputs))]
        (~ (return$ method_output))))))

(def: (state_modifier$ sm)
  (-> State Code)
  (case sm
    #VolatileS (' "volatile")
    #FinalS    (' "final")
    #DefaultS  (' "default")))

(def: (field_decl$ [[name pm anns] field])
  (-> [Member_Declaration FieldDecl] Code)
  (case field
    (#ConstantField class value)
    (` ("constant" (~ (code.text name))
        [(~+ (list\each annotation$ anns))]
        (~ (value$ class))
        (~ value)
        ))

    (#VariableField sm class)
    (` ("variable" (~ (code.text name))
        (~ (privacy_modifier$ pm))
        (~ (state_modifier$ sm))
        [(~+ (list\each annotation$ anns))]
        (~ (value$ class))
        ))
    ))

(def: (argument$ [name type])
  (-> Argument Code)
  (` [(~ (code.text name)) (~ (value$ type))]))

(def: (constructor_arg$ [class term])
  (-> (Typed Code) Code)
  (` [(~ (value$ class)) (~ term)]))

(def: (method_def$ fully_qualified_class_name method_parser super_class fields [[name pm anns] method_def])
  (-> External (Parser Code) (Type Class) (List [Member_Declaration FieldDecl]) [Member_Declaration Method_Definition] Code)
  (case method_def
    (#ConstructorMethod strict_fp? type_vars self_name arguments constructor_args body exs)
    (let [replacer (|> (list\each (field->parser fully_qualified_class_name self_name) fields)
                       (list\mix <>.either method_parser)
                       parser->replacer)]
      (` ("init"
          (~ (privacy_modifier$ pm))
          (~ (code.bit strict_fp?))
          [(~+ (list\each annotation$ anns))]
          [(~+ (list\each var$ type_vars))]
          [(~+ (list\each class$ exs))]
          (~ (code.text self_name))
          [(~+ (list\each argument$ arguments))]
          [(~+ (list\each constructor_arg$ constructor_args))]
          (~ (replaced replacer body))
          )))
    
    (#VirtualMethod final? strict_fp? type_vars self_name arguments return_type body exs)
    (let [replacer (|> (list\each (field->parser fully_qualified_class_name self_name) fields)
                       (list\mix <>.either method_parser)
                       parser->replacer)]
      (` ("virtual"
          (~ (code.text name))
          (~ (privacy_modifier$ pm))
          (~ (code.bit final?))
          (~ (code.bit strict_fp?))
          [(~+ (list\each annotation$ anns))]
          [(~+ (list\each var$ type_vars))]
          (~ (code.text self_name))
          [(~+ (list\each argument$ arguments))]
          (~ (return$ return_type))
          [(~+ (list\each class$ exs))]
          (~ (replaced replacer body)))))
    
    (#OverridenMethod strict_fp? declaration type_vars self_name arguments return_type body exs)
    (let [replacer (|> (list\each (field->parser fully_qualified_class_name self_name) fields)
                       (list\mix <>.either method_parser)
                       parser->replacer)
          super_replacer (parser->replacer (<code>.form (do <>.monad
                                                          [_ (<code>.this! (' ::super!))
                                                           args (<code>.tuple (<>.exactly (list.size arguments) <code>.any))]
                                                          (in (` ("jvm member invoke special"
                                                                  (~ (code.text (product.left (parser.read_class super_class))))
                                                                  (~ (code.text name))
                                                                  (~ (code.local_identifier self_name))
                                                                  (~+ (|> args
                                                                          (list.zipped/2 (list\each product.right arguments))
                                                                          (list\each ..decorate_input)))))))))]
      (` ("override"
          (~ (declaration$ declaration))
          (~ (code.text name))
          (~ (code.bit strict_fp?))
          [(~+ (list\each annotation$ anns))]
          [(~+ (list\each var$ type_vars))]
          (~ (code.text self_name))
          [(~+ (list\each argument$ arguments))]
          (~ (return$ return_type))
          [(~+ (list\each class$ exs))]
          (~ (|> body
                 (replaced replacer)
                 (replaced super_replacer)))
          )))

    (#StaticMethod strict_fp? type_vars arguments return_type body exs)
    (let [replacer (parser->replacer (<>.failure ""))]
      (` ("static"
          (~ (code.text name))
          (~ (privacy_modifier$ pm))
          (~ (code.bit strict_fp?))
          [(~+ (list\each annotation$ anns))]
          [(~+ (list\each var$ type_vars))]
          [(~+ (list\each argument$ arguments))]
          (~ (return$ return_type))
          [(~+ (list\each class$ exs))]
          (~ (replaced replacer body)))))

    (#AbstractMethod type_vars arguments return_type exs)
    (` ("abstract"
        (~ (code.text name))
        (~ (privacy_modifier$ pm))
        [(~+ (list\each annotation$ anns))]
        [(~+ (list\each var$ type_vars))]
        [(~+ (list\each argument$ arguments))]
        (~ (return$ return_type))
        [(~+ (list\each class$ exs))]))

    (#NativeMethod type_vars arguments return_type exs)
    (` ("native"
        (~ (code.text name))
        (~ (privacy_modifier$ pm))
        [(~+ (list\each annotation$ anns))]
        [(~+ (list\each var$ type_vars))]
        [(~+ (list\each class$ exs))]
        [(~+ (list\each argument$ arguments))]
        (~ (return$ return_type))))
    ))

(def: (complete_call$ g!obj [method args])
  (-> Code Partial_Call Code)
  (` ((~ (code.identifier method)) (~+ args) (~ g!obj))))

(def: $Object
  (Type Class)
  (type.class "java.lang.Object" (list)))

(syntax: .public (class: [.let [! <>.monad]
                          im inheritance_modifier^
                          [full_class_name class_vars] (\ ! each parser.declaration ..declaration^)
                          super (<>.else $Object
                                         (class^ class_vars))
                          interfaces (<>.else (list)
                                              (<code>.tuple (<>.some (class^ class_vars))))
                          annotations ..annotations^
                          fields (<>.some (..field_decl^ class_vars))
                          methods (<>.some (..method_def^ class_vars))])
  (do meta.monad
    [.let [fully_qualified_class_name full_class_name
           method_parser (: (Parser Code)
                            (|> methods
                                (list\each (method->parser fully_qualified_class_name))
                                (list\mix <>.either (<>.failure ""))))]]
    (in (list (` ("jvm class"
                  (~ (declaration$ (type.declaration full_class_name class_vars)))
                  (~ (class$ super))
                  [(~+ (list\each class$ interfaces))]
                  (~ (inheritance_modifier$ im))
                  [(~+ (list\each annotation$ annotations))]
                  [(~+ (list\each field_decl$ fields))]
                  [(~+ (list\each (method_def$ fully_qualified_class_name method_parser super fields) methods))]))))))

(syntax: .public (interface: [.let [! <>.monad]
                              [full_class_name class_vars] (\ ! each parser.declaration ..declaration^)
                              supers (<>.else (list)
                                              (<code>.tuple (<>.some (class^ class_vars))))
                              annotations ..annotations^
                              members (<>.some (..method_decl^ class_vars))])
  (in (list (` ("jvm class interface"
                (~ (declaration$ (type.declaration full_class_name class_vars)))
                [(~+ (list\each class$ supers))]
                [(~+ (list\each annotation$ annotations))]
                (~+ (list\each method_decl$ members)))))))

(syntax: .public (object [class_vars ..vars^
                          super (<>.else $Object
                                         (class^ class_vars))
                          interfaces (<>.else (list)
                                              (<code>.tuple (<>.some (class^ class_vars))))
                          constructor_args (..constructor_args^ class_vars)
                          methods (<>.some ..overriden_method_def^)])
  (in (list (` ("jvm class anonymous"
                [(~+ (list\each var$ class_vars))]
                (~ (class$ super))
                [(~+ (list\each class$ interfaces))]
                [(~+ (list\each constructor_arg$ constructor_args))]
                [(~+ (list\each (method_def$ "" (<>.failure "") super (list)) methods))])))))

(syntax: .public (null [])
  (in (list (` ("jvm object null")))))

(def: .public (null? obj)
  (-> (primitive "java.lang.Object") Bit)
  ("jvm object null?" obj))

(syntax: .public (??? [expr <code>.any])
  (with_identifiers [g!temp]
    (in (list (` (let [(~ g!temp) (~ expr)]
                   (if ("jvm object null?" (~ g!temp))
                     #.None
                     (#.Some (~ g!temp)))))))))

(syntax: .public (!!! [expr <code>.any])
  (with_identifiers [g!value]
    (in (list (` ({(#.Some (~ g!value))
                   (~ g!value)

                   #.None
                   ("jvm object null")}
                  (~ expr)))))))

(syntax: .public (check [class (..type^ (list))
                         unchecked (<>.maybe <code>.any)])
  (with_identifiers [g!_ g!unchecked]
    (let [class_name (..reflection class)
          class_type (` (.primitive (~ (code.text class_name))))
          check_type (` (.Maybe (~ class_type)))
          check_code (` (if ("jvm object instance?" (~ (code.text class_name)) (~ g!unchecked))
                          (#.Some (.:as (~ class_type)
                                        (~ g!unchecked)))
                          #.None))]
      (case unchecked
        (#.Some unchecked)
        (in (list (` (: (~ check_type)
                        (let [(~ g!unchecked) (~ unchecked)]
                          (~ check_code))))))

        #.None
        (in (list (` (: (-> (primitive "java.lang.Object") (~ check_type))
                        (function ((~ g!_) (~ g!unchecked))
                          (~ check_code))))))
        ))))

(syntax: .public (synchronized [lock <code>.any
                                body <code>.any])
  (in (list (` ("jvm object synchronized" (~ lock) (~ body))))))

(syntax: .public (do_to [obj <code>.any
                         methods (<>.some partial_call^)])
  (with_identifiers [g!obj]
    (in (list (` (let [(~ g!obj) (~ obj)]
                   (exec (~+ (list\each (complete_call$ g!obj) methods))
                     (~ g!obj))))))))

(def: (class_import$ declaration)
  (-> (Type Declaration) Code)
  (let [[full_name params] (parser.declaration declaration)
        def_name (..internal full_name)
        params' (list\each ..var$' params)]
    (template.with_locals [g!_]
      (` (def: (~ (code.identifier ["" def_name]))
           {#..jvm_class (~ (code.text (..internal full_name)))}
           .Type
           (All ((~ (' g!_)) (~+ params'))
             (primitive (~ (code.text full_name))
                        [(~+ params')])))))))

(def: (member_type_vars class_tvars member)
  (-> (List (Type Var)) Import_Member_Declaration (List (Type Var)))
  (case member
    (#ConstructorDecl [commons _])
    (list\composite class_tvars (value@ #import_member_tvars commons))

    (#MethodDecl [commons _])
    (case (value@ #import_member_kind commons)
      #StaticIMK
      (value@ #import_member_tvars commons)

      _
      (list\composite class_tvars (value@ #import_member_tvars commons)))

    _
    class_tvars))

(def: (member_def_arg_bindings vars member)
  (-> (List (Type Var)) Import_Member_Declaration (Meta [(List [Bit Code]) (List (Type Value)) (List Code)]))
  (case member
    (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
    (let [(^slots [#import_member_tvars #import_member_args]) commons]
      (do {! meta.monad}
        [arg_inputs (monad.each !
                                (: (-> [Bit (Type Value)] (Meta [Bit Code]))
                                   (function (_ [maybe? _])
                                     (with_identifiers [arg_name]
                                       (in [maybe? arg_name]))))
                                import_member_args)
         .let [input_jvm_types (list\each product.right import_member_args)
               arg_types (list\each (: (-> [Bit (Type Value)] Code)
                                       (function (_ [maybe? arg])
                                         (let [arg_type (value_type (value@ #import_member_mode commons) arg)]
                                           (if maybe?
                                             (` (Maybe (~ arg_type)))
                                             arg_type))))
                                    import_member_args)]]
        (in [arg_inputs input_jvm_types arg_types])))

    _
    (\ meta.monad in [(list) (list) (list)])))

(def: (with_return_maybe member never_null? unboxed return_term)
  (-> Import_Member_Declaration Bit (Type Value) Code Code)
  (case member
    (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
    (cond (or never_null?
              (dictionary.key? ..boxes unboxed))
          return_term

          (value@ #import_member_maybe? commons)
          (` (??? (~ return_term)))

          ... else
          (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))]
            (` (let [(~ g!temp) (~ return_term)]
                 (if (not (..null? (.:as (primitive "java.lang.Object")
                                         (~ g!temp))))
                   (~ g!temp)
                   (panic! "Cannot produce null references from method calls."))))))

    _
    return_term))

(template [<name> <tag> <term_trans>]
  [(def: (<name> member return_term)
     (-> Import_Member_Declaration Code Code)
     (case member
       (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
       (if (value@ <tag> commons)
         <term_trans>
         return_term)

       _
       return_term))]

  [with_return_try #import_member_try? (` (.try (~ return_term)))]
  [with_return_io  #import_member_io?  (` ((~! io.io) (~ return_term)))]
  )

(def: $String
  (type.class "java.lang.String" (list)))

(template [<input?> <name> <unbox/box> <special+>]
  [(def: (<name> mode [unboxed raw])
     (-> Primitive_Mode [(Type Value) Code] Code)
     (let [[unboxed refined post] (: [(Type Value) Code (List Code)]
                                     (case mode
                                       #ManualPrM
                                       [unboxed raw (list)]
                                       
                                       #AutoPrM
                                       (with_expansions [<special+>' (template.spliced <special+>)
                                                         <cond_cases> (template [<old> <new> <pre> <post>]
                                                                        [(\ type.equivalence = <old> unboxed)
                                                                         (with_expansions [<post>' (template.spliced <post>)]
                                                                           [<new>
                                                                            (` (.|> (~ raw) (~+ <pre>)))
                                                                            (list <post>')])]

                                                                        <special+>')]
                                         (cond <cond_cases>
                                               ... else
                                               [unboxed
                                                (if <input?>
                                                  (` ("jvm object cast" (~ raw)))
                                                  raw)
                                                (list)]))))
           unboxed/boxed (case (dictionary.value unboxed ..boxes)
                           (#.Some boxed)
                           (<unbox/box> unboxed boxed refined)
                           
                           #.None
                           refined)]
       (case post
         #.End
         unboxed/boxed

         _
         (` (.|> (~ unboxed/boxed) (~+ post))))))]

  [#1 with_automatic_input_conversion ..unbox
   [[type.boolean type.boolean (list (` (.: .Bit)) (` (.:as (.primitive (~ (code.text box.boolean)))))) []]
    [type.byte type.byte (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_byte)) []]
    [type.short type.short (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_short)) []]
    [type.int type.int (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_int)) []]
    [type.long type.long (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long)))))) []]
    [type.float type.float (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double))))) (` ..double_to_float)) []]
    [type.double type.double (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double)))))) []]
    [..$String ..$String (list (` (.: .Text)) (` (.:as (.primitive (~ (code.text (..reflection ..$String))))))) []]
    [(type.class box.boolean (list)) (type.class box.boolean (list)) (list (` (.: .Bit)) (` (.:as (.primitive (~ (code.text box.boolean)))))) []]
    [(type.class box.long (list)) (type.class box.long (list)) (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long)))))) []]
    [(type.class box.double (list)) (type.class box.double (list)) (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double)))))) []]]]
  [#0 with_automatic_output_conversion ..box
   [[type.boolean type.boolean (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:as .Bit))]]
    [type.byte type.long (list (` "jvm conversion byte-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
    [type.short type.long (list (` "jvm conversion short-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
    [type.int type.long (list (` "jvm conversion int-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
    [type.long type.long (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
    [type.float type.double (list (` "jvm conversion float-to-double")) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]]
    [type.double type.double (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]]
    [..$String ..$String (list) [(` (.: (.primitive (~ (code.text (..reflection ..$String)))))) (` (.:as .Text))]]
    [(type.class box.boolean (list)) (type.class box.boolean (list)) (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:as .Bit))]]
    [(type.class box.long (list)) (type.class box.long (list)) (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]]
    [(type.class box.double (list)) (type.class box.double (list)) (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]]]]
  )

(def: (un_quoted quoted)
  (-> Code Code)
  (` ((~' ~) (~ quoted))))

(def: (jvm_invoke_inputs mode classes inputs)
  (-> Primitive_Mode (List (Type Value)) (List [Bit Code]) (List Code))
  (|> inputs
      (list.zipped/2 classes)
      (list\each (function (_ [class [maybe? input]])
                   (|> (if maybe?
                         (` (: (.primitive (~ (code.text (..reflection class))))
                               ((~! !!!) (~ (..un_quoted input)))))
                         (..un_quoted input))
                       [class]
                       (with_automatic_input_conversion mode))))))

(def: (import_name format class member)
  (-> Text Text Text Text)
  (|> format
      (text.replaced "#" class)
      (text.replaced "." member)))

(def: syntax_inputs
  (-> (List Code) (List Code))
  (|>> (list\each (function (_ name)
                    (list name (` (~! <code>.any)))))
       list\conjoint))

(def: (member_def_interop vars kind class [arg_function_inputs input_jvm_types arg_types] member method_prefix import_format)
  (-> (List (Type Var)) Class_Kind (Type Declaration) [(List [Bit Code]) (List (Type Value)) (List Code)] Import_Member_Declaration Text Text (Meta (List Code)))
  (let [[full_name class_tvars] (parser.declaration class)]
    (case member
      (#EnumDecl enum_members)
      (with_identifiers [g!_]
        (do meta.monad
          [.let [enum_type (: Code
                              (case class_tvars
                                #.End
                                (` (primitive (~ (code.text full_name))))

                                _
                                (let [=class_tvars (list\each ..var$' class_tvars)]
                                  (` (All ((~ g!_) (~+ =class_tvars)) (primitive (~ (code.text full_name)) [(~+ =class_tvars)]))))))
                 getter_interop (: (-> Text Code)
                                   (function (_ name)
                                     (let [getter_name (code.identifier ["" (..import_name import_format method_prefix name)])]
                                       (` (def: (~ getter_name)
                                            (~ enum_type)
                                            (~ (get_static_field full_name name)))))))]]
          (in (list\each getter_interop enum_members))))
      
      (#ConstructorDecl [commons _])
      (do meta.monad
        [.let [classT (type.class full_name (list))
               def_name (code.identifier ["" (..import_name import_format method_prefix (value@ #import_member_alias commons))])
               jvm_interop (|> [classT
                                (` ("jvm member invoke constructor"
                                    [(~+ (list\each ..var$ class_tvars))]
                                    (~ (code.text full_name))
                                    [(~+ (list\each ..var$ (value@ #import_member_tvars commons)))]
                                    (~+ (|> (jvm_invoke_inputs (value@ #import_member_mode commons) input_jvm_types arg_function_inputs)
                                            (list.zipped/2 input_jvm_types)
                                            (list\each ..decorate_input)))))]
                               (with_automatic_output_conversion (value@ #import_member_mode commons))
                               (with_return_maybe member true classT)
                               (with_return_try member)
                               (with_return_io member))]]
        (in (list (` ((~! syntax:) ((~ def_name) [(~+ (syntax_inputs (list\each product.right arg_function_inputs)))])
                      ((~' in) (.list (.` (~ jvm_interop)))))))))

      (#MethodDecl [commons method])
      (with_identifiers [g!obj]
        (do meta.monad
          [.let [def_name (code.identifier ["" (..import_name import_format method_prefix (value@ #import_member_alias commons))])
                 (^slots [#import_member_kind]) commons
                 (^slots [#import_method_name]) method
                 [jvm_op object_ast] (: [Text (List Code)]
                                        (case import_member_kind
                                          #StaticIMK
                                          ["jvm member invoke static"
                                           (list)]

                                          #VirtualIMK
                                          (case kind
                                            #Class
                                            ["jvm member invoke virtual"
                                             (list g!obj)]
                                            
                                            #Interface
                                            ["jvm member invoke interface"
                                             (list g!obj)]
                                            )))
                 method_return (value@ #import_method_return method)
                 callC (: Code
                          (` ((~ (code.text jvm_op))
                              [(~+ (list\each ..var$ class_tvars))]
                              (~ (code.text full_name))
                              (~ (code.text import_method_name))
                              [(~+ (list\each ..var$ (value@ #import_member_tvars commons)))]
                              (~+ (|> object_ast
                                      (list\each ..un_quoted)
                                      (list.zipped/2 (list (type.class full_name (list))))
                                      (list\each (with_automatic_input_conversion (value@ #import_member_mode commons)))))
                              (~+ (|> (jvm_invoke_inputs (value@ #import_member_mode commons) input_jvm_types arg_function_inputs)
                                      (list.zipped/2 input_jvm_types)
                                      (list\each ..decorate_input))))))
                 jvm_interop (: Code
                                (case (type.void? method_return)
                                  (#.Left method_return)
                                  (|> [method_return
                                       callC]
                                      (with_automatic_output_conversion (value@ #import_member_mode commons))
                                      (with_return_maybe member false method_return)
                                      (with_return_try member)
                                      (with_return_io member))
                                  
                                  
                                  (#.Right method_return)
                                  (|> callC
                                      (with_return_try member)
                                      (with_return_io member))))]]
          (in (list (` ((~! syntax:) ((~ def_name) [(~+ (syntax_inputs (list\each product.right arg_function_inputs)))
                                                    (~+ (syntax_inputs object_ast))])
                        ((~' in) (.list (.` (~ jvm_interop))))))))))

      (#FieldAccessDecl fad)
      (do meta.monad
        [.let [(^open ".") fad
               getter_name (code.identifier ["" (..import_name import_format method_prefix import_field_name)])
               setter_name (code.identifier ["" (..import_name import_format method_prefix (format import_field_name "!"))])]
         getter_interop (with_identifiers [g!obj]
                          (let [getter_call (if import_field_static?
                                              (` ((~ getter_name) []))
                                              (` ((~ getter_name) [(~ g!obj) (~! <code>.any)])))
                                getter_body (<| (with_automatic_output_conversion import_field_mode)
                                                [import_field_type
                                                 (if import_field_static?
                                                   (get_static_field full_name import_field_name)
                                                   (get_virtual_field full_name import_field_name (..un_quoted g!obj)))])
                                getter_body (if import_field_maybe?
                                              (` ((~! ???) (~ getter_body)))
                                              getter_body)
                                getter_body (if import_field_setter?
                                              (` ((~! io.io) (~ getter_body)))
                                              getter_body)]
                            (in (` ((~! syntax:) (~ getter_call)
                                    ((~' in) (.list (.` (~ getter_body)))))))))
         setter_interop (: (Meta (List Code))
                           (if import_field_setter?
                             (with_identifiers [g!obj g!value]
                               (let [setter_call (if import_field_static?
                                                   (` ((~ setter_name) [(~ g!value) (~! <code>.any)]))
                                                   (` ((~ setter_name) [(~ g!value) (~! <code>.any)
                                                                        (~ g!obj) (~! <code>.any)])))
                                     setter_value (|> [import_field_type (..un_quoted g!value)]
                                                      (with_automatic_input_conversion import_field_mode))
                                     setter_value (if import_field_maybe?
                                                    (` ((~! !!!) (~ setter_value)))
                                                    setter_value)
                                     setter_command (format (if import_field_static? "jvm putstatic" "jvm putfield")
                                                            ":" full_name ":" import_field_name)
                                     g!obj+ (: (List Code)
                                               (if import_field_static?
                                                 (list)
                                                 (list (..un_quoted g!obj))))]
                                 (in (list (` ((~! syntax:) (~ setter_call)
                                               ((~' in) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value))))))))))))
                             (in (list))))]
        (in (list& getter_interop setter_interop)))
      )))

(def: (member_import$ vars kind class [import_format member])
  (-> (List (Type Var)) Class_Kind (Type Declaration) [Text Import_Member_Declaration] (Meta (List Code)))
  (let [[full_name _] (parser.declaration class)
        method_prefix (..internal full_name)]
    (do meta.monad
      [=args (member_def_arg_bindings vars member)]
      (member_def_interop vars kind class =args member method_prefix import_format))))

(def: interface?
  (All (_ a) (-> (primitive "java.lang.Class" [a]) Bit))
  (|>> ("jvm member invoke virtual" [] "java.lang.Class" "isInterface" [])
       "jvm object cast"
       (: ..Boolean)
       (.:as Bit)))

(def: load_class
  (-> External (Try (primitive "java.lang.Class" [Any])))
  (|>> (.:as (primitive "java.lang.String"))
       ["Ljava/lang/String;"]
       ("jvm member invoke static" [] "java.lang.Class" "forName" [])
       try))

(def: (class_kind declaration)
  (-> (Type Declaration) (Meta Class_Kind))
  (let [[class_name _] (parser.declaration declaration)]
    (case (load_class class_name)
      (#.Right class)
      (\ meta.monad in (if (interface? class)
                         #Interface
                         #Class))

      (#.Left _)
      (meta.failure (format "Unknown class: " class_name)))))

(syntax: .public (import: [declaration ..declaration^
                           .let [[class_name class_type_vars] (parser.declaration declaration)]
                           bundles (<>.some (..bundle class_type_vars))])
  (do {! meta.monad}
    [kind (class_kind declaration)
     =members (|> bundles
                  (list\each (function (_ [import_format members])
                               (list\each (|>> [import_format]) members)))
                  list.together
                  (monad.each ! (member_import$ class_type_vars kind declaration)))]
    (in (list& (class_import$ declaration) (list\conjoint =members)))))

(syntax: .public (array [type (..type^ (list))
                         size <code>.any])
  (let [g!size (` (|> (~ size)
                      (.: .Nat)
                      (.:as (.primitive (~ (code.text box.long))))
                      "jvm object cast"
                      "jvm conversion long-to-int"))]
    (`` (cond (~~ (template [<primitive> <array_op>]
                    [(\ type.equivalence = <primitive> type)
                     (in (list (` (<array_op> (~ g!size)))))]

                    [type.boolean "jvm array new boolean"]
                    [type.byte    "jvm array new byte"]
                    [type.short   "jvm array new short"]
                    [type.int     "jvm array new int"]
                    [type.long    "jvm array new long"]
                    [type.float   "jvm array new float"]
                    [type.double  "jvm array new double"]
                    [type.char    "jvm array new char"]))
              ... else
              (in (list (` (: (~ (value_type #ManualPrM (type.array type)))
                              ("jvm array new object" (~ g!size))))))))))

(exception: .public (cannot_convert_to_jvm_type {type .Type})
  (exception.report
   ["Lux Type" (%.type type)]))

(with_expansions [<failure> (as_is (meta.failure (exception.error ..cannot_convert_to_jvm_type [type])))]
  (def: (lux_type->jvm_type type)
    (-> .Type (Meta (Type Value)))
    (if (lux_type\= .Any type)
      (\ meta.monad in $Object)
      (case type
        (#.Primitive name params)
        (`` (cond (~~ (template [<type>]
                        [(text\= (..reflection <type>) name)
                         (case params
                           #.End
                           (\ meta.monad in <type>)

                           _
                           <failure>)]
                        
                        [type.boolean]
                        [type.byte]
                        [type.short]
                        [type.int]
                        [type.long]
                        [type.float]
                        [type.double]
                        [type.char]))

                  (~~ (template [<type>]
                        [(text\= (..reflection (type.array <type>)) name)
                         (case params
                           #.End
                           (\ meta.monad in (type.array <type>))

                           _
                           <failure>)]
                        
                        [type.boolean]
                        [type.byte]
                        [type.short]
                        [type.int]
                        [type.long]
                        [type.float]
                        [type.double]
                        [type.char]))

                  (text\= array.type_name name)
                  (case params
                    (#.Item elementLT #.End)
                    (\ meta.monad each type.array
                       (lux_type->jvm_type elementLT))

                    _
                    <failure>)

                  (text.starts_with? descriptor.array_prefix name)
                  (case params
                    #.End
                    (let [[_ unprefixed] (maybe.trusted (text.split_by descriptor.array_prefix name))]
                      (\ meta.monad each type.array
                         (lux_type->jvm_type (#.Primitive unprefixed (list)))))

                    _
                    <failure>)

                  ... else
                  (\ meta.monad each (type.class name)
                     (: (Meta (List (Type Parameter)))
                        (monad.each meta.monad
                                    (function (_ paramLT)
                                      (do meta.monad
                                        [paramJT (lux_type->jvm_type paramLT)]
                                        (case (parser.parameter? paramJT)
                                          (#.Some paramJT)
                                          (in paramJT)

                                          #.None
                                          <failure>)))
                                    params)))))

        (#.Apply A F)
        (case (lux_type.applied (list A) F)
          #.None
          <failure>

          (#.Some type')
          (lux_type->jvm_type type'))
        
        (#.Named _ type')
        (lux_type->jvm_type type')

        _
        <failure>))))

(syntax: .public (length [array <code>.any])
  (case array
    [_ (#.Identifier array_name)]
    (do meta.monad
      [array_type (meta.type array_name)
       array_jvm_type (lux_type->jvm_type array_type)
       .let [g!extension (code.text (`` (cond (~~ (template [<primitive> <extension>]
                                                    [(\ type.equivalence =
                                                        (type.array <primitive>)
                                                        array_jvm_type)
                                                     <extension>]

                                                    [type.boolean "jvm array length boolean"]
                                                    [type.byte "jvm array length byte"]
                                                    [type.short "jvm array length short"]
                                                    [type.int "jvm array length int"]
                                                    [type.long "jvm array length long"]
                                                    [type.float "jvm array length float"]
                                                    [type.double "jvm array length double"]
                                                    [type.char "jvm array length char"]))
                                              
                                              ... else
                                              "jvm array length object")))]]
      (in (list (` (.|> ((~ g!extension) (~ array))
                        "jvm conversion int-to-long"
                        "jvm object cast"
                        (.: (.primitive (~ (code.text box.long))))
                        (.:as .Nat))))))

    _
    (with_identifiers [g!array]
      (in (list (` (let [(~ g!array) (~ array)]
                     (..length (~ g!array)))))))))

(syntax: .public (read! [idx <code>.any
                         array <code>.any])
  (case array
    [_ (#.Identifier array_name)]
    (do meta.monad
      [array_type (meta.type array_name)
       array_jvm_type (lux_type->jvm_type array_type)
       .let [g!idx (` (.|> (~ idx)
                           (.: .Nat)
                           (.:as (.primitive (~ (code.text box.long))))
                           "jvm object cast"
                           "jvm conversion long-to-int"))]]
      (`` (cond (~~ (template [<primitive> <extension> <box>]
                      [(\ type.equivalence =
                          (type.array <primitive>)
                          array_jvm_type)
                       (in (list (` (.|> (<extension> (~ g!idx) (~ array))
                                         "jvm object cast"
                                         (.: (.primitive (~ (code.text <box>))))))))]

                      [type.boolean "jvm array read boolean" box.boolean]
                      [type.byte "jvm array read byte" box.byte]
                      [type.short "jvm array read short" box.short]
                      [type.int "jvm array read int" box.int]
                      [type.long "jvm array read long" box.long]
                      [type.float "jvm array read float" box.float]
                      [type.double "jvm array read double" box.double]
                      [type.char "jvm array read char" box.char]))
                
                ... else
                (in (list (` ("jvm array read object" (~ g!idx) (~ array))))))))

    _
    (with_identifiers [g!array]
      (in (list (` (let [(~ g!array) (~ array)]
                     (..read! (~ idx) (~ g!array)))))))))

(syntax: .public (write! [idx <code>.any
                          value <code>.any
                          array <code>.any])
  (case array
    [_ (#.Identifier array_name)]
    (do meta.monad
      [array_type (meta.type array_name)
       array_jvm_type (lux_type->jvm_type array_type)
       .let [g!idx (` (.|> (~ idx)
                           (.: .Nat)
                           (.:as (.primitive (~ (code.text box.long))))
                           "jvm object cast"
                           "jvm conversion long-to-int"))]]
      (`` (cond (~~ (template [<primitive> <extension> <box>]
                      [(\ type.equivalence =
                          (type.array <primitive>)
                          array_jvm_type)
                       (let [g!value (` (.|> (~ value)
                                             (.:as (.primitive (~ (code.text <box>))))
                                             "jvm object cast"))]
                         (in (list (` (<extension> (~ g!idx) (~ g!value) (~ array))))))]

                      [type.boolean "jvm array write boolean" box.boolean]
                      [type.byte "jvm array write byte" box.byte]
                      [type.short "jvm array write short" box.short]
                      [type.int "jvm array write int" box.int]
                      [type.long "jvm array write long" box.long]
                      [type.float "jvm array write float" box.float]
                      [type.double "jvm array write double" box.double]
                      [type.char "jvm array write char" box.char]))
                
                ... else
                (in (list (` ("jvm array write object" (~ g!idx) (~ value) (~ array))))))))

    _
    (with_identifiers [g!array]
      (in (list (` (let [(~ g!array) (~ array)]
                     (..write! (~ idx) (~ value) (~ g!array)))))))))

(syntax: .public (class_for [type (..type^ (list))])
  (in (list (` ("jvm object class" (~ (code.text (..reflection type))))))))

(syntax: .public (type [type (..type^ (list))])
  (in (list (..value_type #ManualPrM type))))

(exception: .public (cannot_cast_to_non_object {type (Type Value)})
  (exception.report
   ["Signature" (..signature type)]
   ["Reflection" (..reflection type)]))

(syntax: .public (:as [type (..type^ (list))
                       object <code>.any])
  (case [(parser.array? type)
         (parser.class? type)]
    (^or [(#.Some _) _] [_ (#.Some _)])
    (in (list (` (.: (~ (..value_type #ManualPrM type))
                     ("jvm object cast" (~ object))))))

    _
    (meta.failure (exception.error ..cannot_cast_to_non_object [type]))))