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

(.using
 [library
  [lux {"-" is as type}
   ["[0]" type ("[1]#[0]" equivalence)]
   [abstract
    ["[0]" monad {"+" Monad do}]
    ["[0]" enum]]
   [control
    ["[0]" function]
    ["[0]" io]
    ["[0]" maybe]
    ["[0]" try {"+" Try}]
    ["<>" parser
     ["<[0]>" code {"+" Parser}]]]
   [data
    ["[0]" product]
    ["[0]" bit ("[1]#[0]" codec)]
    ["[0]" text ("[1]#[0]" equivalence monoid)
     ["%" format {"+" format}]]
    [collection
     ["[0]" array {"+" Array}]
     ["[0]" list ("[1]#[0]" monad mix monoid)]]]
   ["[0]" macro {"+" with_symbols}
    [syntax {"+" syntax:}]
    ["^" pattern]
    ["[0]" code]
    ["[0]" template]]
   ["[0]" meta]]])

(template [<name> <op> <from> <to>]
  [(def: .public (<name> value)
     (-> (Primitive <from>) (Primitive <to>))
     (<op> value))]

  [byte_to_long "jvm convert byte-to-long" "java.lang.Byte"      "java.lang.Long"]

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

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

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

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

(template [<forward> <from> <to> <backward>]
  [(template: .public (<forward> it)
     [(|> it (.is <from>) (.as (Primitive <to>)))])

   (template: .public (<backward> it)
     [(|> it (.is (Primitive <to>)) (.as <from>))])]

  [as_boolean .Bit "java.lang.Boolean" of_boolean]
  [as_long .Int "java.lang.Long" of_long]
  [as_double .Frac "java.lang.Double" of_double]
  [as_string .Text "java.lang.String" of_string]
  )

(template [<forward> <from> <$> <mid> <$'> <to> <backward>]
  [(template: .public (<forward> it)
     [(|> it (.is <from>) (.as (Primitive <mid>)) <$> (.is (Primitive <to>)))])

   (template: .public (<backward> it)
     [(|> it (.is (Primitive <to>)) <$'> (.is (Primitive <mid>)) (.as <from>))])]

  [as_byte .Int ..long_to_byte "java.lang.Long" ..byte_to_long "java.lang.Byte" of_byte]
  [as_short .Int ..long_to_short "java.lang.Long" ..short_to_long "java.lang.Short" of_short]
  [as_int .Int ..long_to_int "java.lang.Long" ..int_to_long "java.lang.Integer" of_int]
  [as_float .Frac ..double_to_float "java.lang.Double" ..float_to_double "java.lang.Float" of_float]
  )

... [Utils]
(def: constructor_method_name "<init>")
(def: member_separator "::")

... Types
(type: JVM_Code
  Text)

(type: BoundKind
  (Variant
   {#UpperBound}
   {#LowerBound}))

(type: GenericType
  (Rec GenericType
    (Variant
     {#GenericTypeVar Text}
     {#GenericClass [Text (List GenericType)]}
     {#GenericArray GenericType}
     {#GenericWildcard (Maybe [BoundKind GenericType])})))

(type: Type_Parameter
  [Text (List GenericType)])

(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: Class_Declaration
  (Record
   [#class_name   Text
    #class_params (List Type_Parameter)]))

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

(type: StackTrace
  (Array StackFrame))

(type: Super_Class_Decl
  (Record
   [#super_class_name   Text
    #super_class_params (List GenericType)]))

(type: AnnotationParam
  [Text Code])

(type: Annotation
  (Record
   [#ann_name   Text
    #ann_params (List AnnotationParam)]))

(type: Member_Declaration
  (Record
   [#member_name Text
    #member_privacy Privacy
    #member_anns (List Annotation)]))

(type: FieldDecl
  (Variant
   {#ConstantField GenericType Code}
   {#VariableField State GenericType}))

(type: MethodDecl
  (Record
   [#method_tvars  (List Type_Parameter)
    #method_inputs (List GenericType)
    #method_output GenericType
    #method_exs    (List GenericType)]))

(type: ArgDecl
  (Record
   [#arg_name Text
    #arg_type GenericType]))

(type: ConstructorArg
  [GenericType Code])

(type: Method_Definition
  (Variant
   {#ConstructorMethod [Bit
                        (List Type_Parameter)
                        (List ArgDecl)
                        (List ConstructorArg)
                        Code
                        (List GenericType)]}
   {#VirtualMethod [Bit
                    Bit
                    (List Type_Parameter)
                    Text
                    (List ArgDecl)
                    GenericType
                    Code
                    (List GenericType)]}
   {#OverridenMethod [Bit
                      Class_Declaration
                      (List Type_Parameter)
                      Text
                      (List ArgDecl)
                      GenericType
                      Code
                      (List GenericType)]}
   {#StaticMethod [Bit
                   (List Type_Parameter)
                   (List ArgDecl)
                   GenericType
                   Code
                   (List GenericType)]}
   {#AbstractMethod [(List Type_Parameter)
                     (List ArgDecl)
                     GenericType
                     (List GenericType)]}
   {#NativeMethod [(List Type_Parameter)
                   (List ArgDecl)
                   GenericType
                   (List GenericType)]}))

(type: Partial_Call
  (Record
   [#pc_method Symbol
    #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_Parameter)
    #import_member_args   (List [Bit GenericType])
    #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  GenericType]))

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

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

... Utils
(def: (manual_primitive_type class)
  (-> Text (Maybe Code))
  (case class
    (^.template [<prim> <type>]
      [<prim>
       {.#Some (' <type>)}])
    (["boolean" (Primitive "java.lang.Boolean")]
     ["byte"    (Primitive "java.lang.Byte")]
     ["short"   (Primitive "java.lang.Short")]
     ["int"     (Primitive "java.lang.Integer")]
     ["long"    (Primitive "java.lang.Long")]
     ["float"   (Primitive "java.lang.Float")]
     ["double"  (Primitive "java.lang.Double")]
     ["char"    (Primitive "java.lang.Character")]
     ["void"    .Any])

    _
    {.#None}))

(def: (auto_primitive_type class)
  (-> Text (Maybe Code))
  (case class
    (^.template [<prim> <type>]
      [<prim>
       {.#Some (' <type>)}])
    (["boolean" .Bit]
     ["byte"    .Int]
     ["short"   .Int]
     ["int"     .Int]
     ["long"    .Int]
     ["float"   .Frac]
     ["double"  .Frac]
     ["void"    .Any])

    _
    {.#None}))

(def: safe
  (-> Text Text)
  (text.replaced "/" "."))

(def: (generic_class_type' mode type_params in_array? name+params
                           class_type')
  (-> Primitive_Mode (List Type_Parameter) Bit [Text (List GenericType)]
      (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code)
      Code)
  (case [name+params mode in_array?]
    (^.multi [[prim {.#End}] {#ManualPrM} #0]
             [(manual_primitive_type prim)
              {.#Some output}])
    output

    (^.multi [[prim {.#End}] {#AutoPrM} #0]
             [(auto_primitive_type prim)
              {.#Some output}])
    output
    
    [[name params] _ _]
    (let [name (safe name)
          =params (list#each (class_type' mode type_params in_array?) params)]
      (` (Primitive (~ (code.text name)) [(~+ =params)])))))

(def: (class_type' mode type_params in_array? class)
  (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code)
  (case class
    {#GenericTypeVar name}
    (case (list.example (function (_ [pname pbounds])
                          (and (text#= name pname)
                               (not (list.empty? pbounds))))
                        type_params)
      {.#None}
      (code.symbol ["" name])

      {.#Some [pname pbounds]}
      (class_type' mode type_params in_array? (maybe.trusted (list.head pbounds))))
    
    {#GenericClass name+params}
    (generic_class_type' mode type_params in_array? name+params
                         class_type')

    {#GenericArray param}
    (let [=param (class_type' mode type_params #1 param)]
      (` ((~! array.Array) (~ =param))))

    (^.or {#GenericWildcard {.#None}}
          {#GenericWildcard {.#Some [{#LowerBound} _]}})
    (` .Any)

    {#GenericWildcard {.#Some [{#UpperBound} upper_bound]}}
    (class_type' mode type_params in_array? upper_bound)
    ))

(def: (class_type mode type_params class)
  (-> Primitive_Mode (List Type_Parameter) GenericType Code)
  (class_type' mode type_params #0 class))

(def: (type_param_type$ [name bounds])
  (-> Type_Parameter Code)
  (code.symbol ["" name]))

(def: (class_decl_type$ (open "[0]"))
  (-> Class_Declaration Code)
  (let [=params (list#each (.is (-> Type_Parameter Code)
                                (function (_ [pname pbounds])
                                  (case pbounds
                                    {.#End}
                                    (code.symbol ["" pname])

                                    {.#Item bound1 _}
                                    (class_type {#ManualPrM} #class_params bound1))))
                           #class_params)]
    (` (Primitive (~ (code.text (safe #class_name)))
                  [(~+ =params)]))))

(def: type_var_class Text "java.lang.Object")

(def: (simple_class$ env class)
  (-> (List Type_Parameter) GenericType Text)
  (case class
    {#GenericTypeVar name}
    (case (list.example (function (_ [pname pbounds])
                          (and (text#= name pname)
                               (not (list.empty? pbounds))))
                        env)
      {.#None}
      type_var_class

      {.#Some [pname pbounds]}
      (simple_class$ env (maybe.trusted (list.head pbounds))))

    (^.or {#GenericWildcard {.#None}}
          {#GenericWildcard {.#Some [{#LowerBound} _]}})
    type_var_class
    
    {#GenericWildcard {.#Some [{#UpperBound} upper_bound]}}
    (simple_class$ env upper_bound)
    
    {#GenericClass name env}
    (safe name)

    {#GenericArray param'}
    (case param'
      {#GenericArray param}
      (format "[" (simple_class$ env param))
      
      (^.template [<prim> <class>]
        [{#GenericClass <prim> {.#End}}
         <class>])
      (["boolean" "[Z"]
       ["byte"    "[B"]
       ["short"   "[S"]
       ["int"     "[I"]
       ["long"    "[J"]
       ["float"   "[F"]
       ["double"  "[D"]
       ["char"    "[C"])
      
      param
      (format "[L" (simple_class$ env param) ";"))
    ))

(def: (get_const_parser class_name field_name)
  (-> Text Text (Parser Code))
  (do <>.monad
    [.let [dotted_name (format "::" field_name)]
     _ (<code>.this (code.symbol ["" dotted_name]))]
    (in (`' ((~ (code.text (format "jvm getstatic" ":" class_name ":" field_name))))))))

(def: (get_var_parser class_name field_name)
  (-> Text Text (Parser Code))
  (do <>.monad
    [.let [dotted_name (format "::" field_name)]
     _ (<code>.this (code.symbol ["" dotted_name]))]
    (in (`' ((~ (code.text (format "jvm getfield" ":" class_name ":" field_name))) _jvm_this)))))

(def: (put_var_parser class_name field_name)
  (-> Text Text (Parser Code))
  (do <>.monad
    [.let [dotted_name (format "::" field_name)]
     [_ _ value] (.is (Parser [Any Any Code])
                      (<code>.form ($_ <>.and (<code>.this (' :=)) (<code>.this (code.symbol ["" dotted_name])) <code>.any)))]
    (in (`' ((~ (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (~ value))))))

(def: (pre_walk_replace f input)
  (-> (-> Code Code) Code Code)
  (case (f input)
    (^.template [<tag>]
      [[meta {<tag> parts}]
       [meta {<tag> (list#each (pre_walk_replace f) parts)}]])
    ([.#Form]
     [.#Variant]
     [.#Tuple])
    
    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 [[field_name _ _] field])
  (-> 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)
               (put_var_parser class_name field_name))))

(def: (constructor_parser params class_name arg_decls)
  (-> (List Type_Parameter) Text (List ArgDecl) (Parser Code))
  (do <>.monad
    [args (.is (Parser (List Code))
               (<code>.form (<>.after (<code>.this (' ::new!))
                                      (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any)))))
     .let [arg_decls' (.is (List Text) (list#each (|>> product.right (simple_class$ params)) arg_decls))]]
    (in (` ((~ (code.text (format "jvm new" ":" class_name ":" (text.interposed "," arg_decls'))))
            (~+ args))))))

(def: (static_method_parser params class_name method_name arg_decls)
  (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code))
  (do <>.monad
    [.let [dotted_name (format "::" method_name "!")]
     args (.is (Parser (List Code))
               (<code>.form (<>.after (<code>.this (code.symbol ["" dotted_name]))
                                      (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any)))))
     .let [arg_decls' (.is (List Text) (list#each (|>> product.right (simple_class$ params)) arg_decls))]]
    (in (`' ((~ (code.text (format "jvm invokestatic" ":" class_name ":" method_name ":" (text.interposed "," arg_decls'))))
             (~+ args))))))

(template [<name> <jvm_op>]
  [(def: (<name> params class_name method_name arg_decls)
     (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code))
     (do <>.monad
       [.let [dotted_name (format "::" method_name "!")]
        args (.is (Parser (List Code))
                  (<code>.form (<>.after (<code>.this (code.symbol ["" dotted_name]))
                                         (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any)))))
        .let [arg_decls' (.is (List Text) (list#each (|>> product.right (simple_class$ params)) arg_decls))]]
       (in (`' ((~ (code.text (format <jvm_op> ":" class_name ":" method_name ":" (text.interposed "," arg_decls'))))
                (~' _jvm_this) (~+ args))))))]

  [special_method_parser "jvm invokespecial"]
  [virtual_method_parser "jvm invokevirtual"]
  )

(def: (method_parser params class_name [[method_name _ _] meth_def])
  (-> (List Type_Parameter) Text [Member_Declaration Method_Definition] (Parser Code))
  (case meth_def
    {#ConstructorMethod strict? type_vars args constructor_args return_expr exs}
    (constructor_parser params class_name args)
    
    {#StaticMethod strict? type_vars args return_type return_expr exs}
    (static_method_parser params class_name method_name args)
    
    (^.or {#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs}
          {#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs})
    (special_method_parser params class_name method_name args)

    {#AbstractMethod type_vars args return_type exs}
    (virtual_method_parser params class_name method_name args)

    {#NativeMethod type_vars args return_type exs}
    (virtual_method_parser params class_name method_name args)))

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

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

(def: bound_kind^
  (Parser BoundKind)
  (<>.or (<code>.this (' <))
         (<code>.this (' >))))

(def: (no_periods_assertion name)
  (-> Text (Parser Any))
  (<>.assertion "Names in class declarations cannot contain periods."
                (not (text.contains? "." name))))

(def: (generic_type^ type_vars)
  (-> (List Type_Parameter) (Parser GenericType))
  (<>.rec
   (function (_ again^)
     ($_ <>.either
         (do <>.monad
           [_ (<code>.this (' ?))]
           (in {#GenericWildcard {.#None}}))
         (<code>.tuple (do <>.monad
                         [_ (<code>.this (' ?))
                          bound_kind bound_kind^
                          bound again^]
                         (in {#GenericWildcard {.#Some [bound_kind bound]}})))
         (do <>.monad
           [name <code>.local
            _ (no_periods_assertion name)]
           (if (list.member? text.equivalence (list#each product.left type_vars) name)
             (in {#GenericTypeVar name})
             (in {#GenericClass name (list)})))
         (<code>.tuple (do <>.monad
                         [component again^]
                         (case component
                           (^.template [<class> <name>]
                             [{#GenericClass <name> {.#End}}
                              (in {#GenericClass <class> (list)})])
                           (["[Z" "boolean"]
                            ["[B" "byte"]
                            ["[S" "short"]
                            ["[I" "int"]
                            ["[J" "long"]
                            ["[F" "float"]
                            ["[D" "double"]
                            ["[C" "char"])

                           _
                           (in {#GenericArray component}))))
         (<code>.form (do <>.monad
                        [name <code>.local
                         _ (no_periods_assertion name)
                         params (<>.some again^)
                         _ (<>.assertion (format name " cannot be a type-parameter!")
                                         (not (list.member? text.equivalence (list#each product.left type_vars) name)))]
                        (in {#GenericClass name params})))
         ))))

(def: type_param^
  (Parser Type_Parameter)
  (<>.either (do <>.monad
               [param_name <code>.local]
               (in [param_name (list)]))
             (<code>.tuple (do <>.monad
                             [param_name <code>.local
                              _ (<code>.this (' <))
                              bounds (<>.many (..generic_type^ (list)))]
                             (in [param_name bounds])))))

(def: type_params^
  (Parser (List Type_Parameter))
  (|> ..type_param^
      <>.some
      <code>.tuple
      (<>.else (list))))

(def: class_decl^
  (Parser Class_Declaration)
  (<>.either (do <>.monad
               [name <code>.local
                _ (no_periods_assertion name)]
               (in [name (list)]))
             (<code>.form (do <>.monad
                            [name <code>.local
                             _ (no_periods_assertion name)
                             params (<>.some ..type_param^)]
                            (in [name params])))
             ))

(def: (super_class_decl^ type_vars)
  (-> (List Type_Parameter) (Parser Super_Class_Decl))
  (<>.either (do <>.monad
               [name <code>.local
                _ (no_periods_assertion name)]
               (in [name (list)]))
             (<code>.form (do <>.monad
                            [name <code>.local
                             _ (no_periods_assertion name)
                             params (<>.some (..generic_type^ type_vars))]
                            (in [name params])))))

(def: annotation_params^
  (Parser (List AnnotationParam))
  (<code>.tuple (<>.some (<>.and <code>.text <code>.any))))

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

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

(def: annotations^
  (Parser (List Annotation))
  (do <>.monad
    [anns?? (<>.maybe ..annotations^')]
    (in (maybe.else (list) anns??))))

(def: (throws_decl'^ type_vars)
  (-> (List Type_Parameter) (Parser (List GenericType)))
  (do <>.monad
    [_ (<code>.this (' "throws"))]
    (<code>.tuple (<>.some (..generic_type^ type_vars)))))

(def: (throws_decl^ type_vars)
  (-> (List Type_Parameter) (Parser (List GenericType)))
  (do <>.monad
    [exs? (<>.maybe (throws_decl'^ type_vars))]
    (in (maybe.else (list) exs?))))

(def: (method_decl^ type_vars)
  (-> (List Type_Parameter) (Parser [Member_Declaration MethodDecl]))
  (<code>.form (do <>.monad
                 [tvars ..type_params^
                  name <code>.local
                  anns ..annotations^
                  inputs (<code>.tuple (<>.some (..generic_type^ type_vars)))
                  output (..generic_type^ type_vars)
                  exs (..throws_decl^ type_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_Parameter) (Parser [Member_Declaration FieldDecl]))
  (<>.either (<code>.form (do <>.monad
                            [_ (<code>.this (' "const"))
                             name <code>.local
                             anns ..annotations^
                             type (..generic_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
                             anns ..annotations^
                             type (..generic_type^ type_vars)]
                            (in [[name pm anns] {#VariableField [sm type]}])))))

(def: (arg_decl^ type_vars)
  (-> (List Type_Parameter) (Parser ArgDecl))
  (<>.and <code>.local
          (..generic_type^ type_vars)))

(def: (arg_decls^ type_vars)
  (-> (List Type_Parameter) (Parser (List ArgDecl)))
  (<code>.tuple (<>.some (arg_decl^ type_vars))))

(def: (constructor_arg^ type_vars)
  (-> (List Type_Parameter) (Parser ConstructorArg))
  (<>.and (..generic_type^ type_vars) <code>.any))

(def: (constructor_args^ type_vars)
  (-> (List Type_Parameter) (Parser (List ConstructorArg)))
  (<code>.tuple (<>.some (constructor_arg^ type_vars))))

(def: (constructor_method^ class_vars)
  (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition]))
  (<code>.form (do <>.monad
                 [pm privacy_modifier^
                  strict_fp? (<>.parses? (<code>.this (' "strict")))
                  method_vars ..type_params^
                  .let [total_vars (list#composite class_vars method_vars)]
                  [_ arg_decls] (<code>.form (<>.and (<code>.this (' new))
                                                     (..arg_decls^ 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 arg_decls constructor_args body exs}]))))

(def: (virtual_method_def^ class_vars)
  (-> (List Type_Parameter) (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 ..type_params^
                  .let [total_vars (list#composite class_vars method_vars)]
                  [name this_name arg_decls] (<code>.form ($_ <>.and
                                                              <code>.local
                                                              <code>.local
                                                              (..arg_decls^ total_vars)))
                  return_type (..generic_type^ 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
                                      this_name arg_decls 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 ..class_decl^
                  method_vars ..type_params^
                  .let [total_vars (list#composite (product.right owner_class) method_vars)]
                  [name this_name arg_decls] (<code>.form ($_ <>.and
                                                              <code>.local
                                                              <code>.local
                                                              (..arg_decls^ total_vars)))
                  return_type (..generic_type^ 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
                                        this_name arg_decls 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 ..type_params^
                  .let [total_vars method_vars]
                  [name arg_decls] (<code>.form (<>.and <code>.local
                                                        (..arg_decls^ total_vars)))
                  return_type (..generic_type^ 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 arg_decls 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 ..type_params^
                  .let [total_vars method_vars]
                  [name arg_decls] (<code>.form (<>.and <code>.local
                                                        (..arg_decls^ total_vars)))
                  return_type (..generic_type^ total_vars)
                  exs (..throws_decl^ total_vars)
                  annotations ..annotations^]
                 (in [[#member_name name
                       #member_privacy pm
                       #member_anns annotations]
                      {#AbstractMethod method_vars arg_decls return_type exs}]))))

(def: native_method_def^
  (Parser [Member_Declaration Method_Definition])
  (<code>.form (do <>.monad
                 [pm privacy_modifier^
                  _ (<code>.this (' "native"))
                  method_vars ..type_params^
                  .let [total_vars method_vars]
                  [name arg_decls] (<code>.form (<>.and <code>.local
                                                        (..arg_decls^ total_vars)))
                  return_type (..generic_type^ total_vars)
                  exs (..throws_decl^ total_vars)
                  annotations ..annotations^]
                 (in [[#member_name name
                       #member_privacy pm
                       #member_anns annotations]
                      {#NativeMethod method_vars arg_decls return_type exs}]))))

(def: (method_def^ class_vars)
  (-> (List Type_Parameter) (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>.symbol (<>.some <code>.any))))

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

(def: (import_member_args^ type_vars)
  (-> (List Type_Parameter) (Parser (List [Bit GenericType])))
  (<code>.tuple (<>.some (<>.and (<>.parses? (<code>.this (' "?"))) (..generic_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_Parameter) (Parser Import_Member_Declaration))
  ($_ <>.either
      (<code>.form (do <>.monad
                     [_ (<code>.this (' "enum"))
                      enum_members (<>.some <code>.local)]
                     (in {#EnumDecl enum_members})))
      (<code>.form (do <>.monad
                     [tvars ..type_params^
                      _ (<code>.this (' 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 (.is (Parser ImportMethodKind)
                                (<>.or (<code>.this (' "static"))
                                       (in [])))
                      tvars ..type_params^
                      name <code>.local
                      ?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 (..generic_type^ 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
                      ?prim_mode (<>.maybe primitive_mode^)
                      gtype (..generic_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]})))
      ))

... Generators
(def: with_parens
  (-> JVM_Code JVM_Code)
  (text.enclosed ["(" ")"]))

(def: with_brackets
  (-> JVM_Code JVM_Code)
  (text.enclosed ["[" "]"]))

(def: spaced
  (-> (List JVM_Code) JVM_Code)
  (text.interposed " "))

(def: (privacy_modifier$ pm)
  (-> Privacy JVM_Code)
  (case pm
    {#PublicP}    "public"
    {#PrivateP}   "private"
    {#ProtectedP} "protected"
    {#DefaultP}   "default"))

(def: (inheritance_modifier$ im)
  (-> Inheritance JVM_Code)
  (case im
    {#FinalI}    "final"
    {#AbstractI} "abstract"
    {#DefaultI}  "default"))

(def: (annotation_param$ [name value])
  (-> AnnotationParam JVM_Code)
  (format name "=" (code.format value)))

(def: (annotation$ [name params])
  (-> Annotation JVM_Code)
  (format "(" name " " "{" (text.interposed text.tab (list#each annotation_param$ params)) "}" ")"))

(def: (bound_kind$ kind)
  (-> BoundKind JVM_Code)
  (case kind
    {#UpperBound} "<"
    {#LowerBound} ">"))

(def: (generic_type$ gtype)
  (-> GenericType JVM_Code)
  (case gtype
    {#GenericTypeVar name}
    name

    {#GenericClass name params}
    (format "(" (safe name) " " (spaced (list#each generic_type$ params)) ")")
    
    {#GenericArray param}
    (format "(" array.type_name " " (generic_type$ param) ")")
    
    {#GenericWildcard {.#None}}
    "?"

    {#GenericWildcard {.#Some [bound_kind bound]}}
    (format (bound_kind$ bound_kind) (generic_type$ bound))))

(def: (type_param$ [name bounds])
  (-> Type_Parameter JVM_Code)
  (format "(" name " " (spaced (list#each generic_type$ bounds)) ")"))

(def: (class_decl$ (open "[0]"))
  (-> Class_Declaration JVM_Code)
  (format "(" (safe #class_name) " " (spaced (list#each type_param$ #class_params)) ")"))

(def: (super_class_decl$ (open "[0]"))
  (-> Super_Class_Decl JVM_Code)
  (format "(" (safe #super_class_name)
          " " (spaced (list#each generic_type$ #super_class_params))
          ")"))

(def: (method_decl$ [[name pm anns] method_decl])
  (-> [Member_Declaration MethodDecl] JVM_Code)
  (let [(open "[0]") method_decl]
    (with_parens
      (spaced (list name
                    (with_brackets (spaced (list#each annotation$ anns)))
                    (with_brackets (spaced (list#each type_param$ #method_tvars)))
                    (with_brackets (spaced (list#each generic_type$ #method_exs)))
                    (with_brackets (spaced (list#each generic_type$ #method_inputs)))
                    (generic_type$ #method_output))
              ))))

(def: (state_modifier$ sm)
  (-> State JVM_Code)
  (case sm
    {#VolatileS} "volatile"
    {#FinalS}    "final"
    {#DefaultS}  "default"))

(def: (field_decl$ [[name pm anns] field])
  (-> [Member_Declaration FieldDecl] JVM_Code)
  (case field
    {#ConstantField class value}
    (with_parens
      (spaced (list "constant" name
                    (with_brackets (spaced (list#each annotation$ anns)))
                    (generic_type$ class)
                    (code.format value))
              ))

    {#VariableField sm class}
    (with_parens
      (spaced (list "variable" name
                    (privacy_modifier$ pm)
                    (state_modifier$ sm)
                    (with_brackets (spaced (list#each annotation$ anns)))
                    (generic_type$ class))
              ))
    ))

(def: (arg_decl$ [name type])
  (-> ArgDecl JVM_Code)
  (with_parens
    (spaced (list name (generic_type$ type)))))

(def: (constructor_arg$ [class term])
  (-> ConstructorArg JVM_Code)
  (with_brackets
    (spaced (list (generic_type$ class) (code.format term)))))

(def: (method_def$ replacer super_class [[name pm anns] method_def])
  (-> (-> Code Code) Super_Class_Decl [Member_Declaration Method_Definition] JVM_Code)
  (case method_def
    {#ConstructorMethod strict_fp? type_vars arg_decls constructor_args body exs}
    (with_parens
      (spaced (list "init"
                    (privacy_modifier$ pm)
                    (bit#encoded strict_fp?)
                    (with_brackets (spaced (list#each annotation$ anns)))
                    (with_brackets (spaced (list#each type_param$ type_vars)))
                    (with_brackets (spaced (list#each generic_type$ exs)))
                    (with_brackets (spaced (list#each arg_decl$ arg_decls)))
                    (with_brackets (spaced (list#each constructor_arg$ constructor_args)))
                    (code.format (pre_walk_replace replacer body))
                    )))
    
    {#VirtualMethod final? strict_fp? type_vars this_name arg_decls return_type body exs}
    (with_parens
      (spaced (list "virtual"
                    name
                    (privacy_modifier$ pm)
                    (bit#encoded final?)
                    (bit#encoded strict_fp?)
                    (with_brackets (spaced (list#each annotation$ anns)))
                    (with_brackets (spaced (list#each type_param$ type_vars)))
                    (with_brackets (spaced (list#each generic_type$ exs)))
                    (with_brackets (spaced (list#each arg_decl$ arg_decls)))
                    (generic_type$ return_type)
                    (code.format (pre_walk_replace replacer (` (let [(~ (code.local this_name)) (~' _jvm_this)]
                                                                 (~ body))))))))
    
    {#OverridenMethod strict_fp? class_decl type_vars this_name arg_decls return_type body exs}
    (let [super_replacer (parser_replacer (<code>.form (do <>.monad
                                                         [_ (<code>.this (' ::super!))
                                                          args (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any))
                                                          .let [arg_decls' (.is (List Text) (list#each (|>> product.right (simple_class$ (list)))
                                                                                                       arg_decls))]]
                                                         (in (`' ((~ (code.text (format "jvm invokespecial"
                                                                                        ":" (the #super_class_name super_class)
                                                                                        ":" name
                                                                                        ":" (text.interposed "," arg_decls'))))
                                                                  (~' _jvm_this) (~+ args)))))))]
      (with_parens
        (spaced (list "override"
                      (class_decl$ class_decl)
                      name
                      (bit#encoded strict_fp?)
                      (with_brackets (spaced (list#each annotation$ anns)))
                      (with_brackets (spaced (list#each type_param$ type_vars)))
                      (with_brackets (spaced (list#each generic_type$ exs)))
                      (with_brackets (spaced (list#each arg_decl$ arg_decls)))
                      (generic_type$ return_type)
                      (|> (` (let [(~ (code.local this_name)) (~' _jvm_this)]
                               (~ body)))
                          (pre_walk_replace replacer)
                          (pre_walk_replace super_replacer)
                          (code.format))
                      ))))

    {#StaticMethod strict_fp? type_vars arg_decls return_type body exs}
    (with_parens
      (spaced (list "static"
                    name
                    (privacy_modifier$ pm)
                    (bit#encoded strict_fp?)
                    (with_brackets (spaced (list#each annotation$ anns)))
                    (with_brackets (spaced (list#each type_param$ type_vars)))
                    (with_brackets (spaced (list#each generic_type$ exs)))
                    (with_brackets (spaced (list#each arg_decl$ arg_decls)))
                    (generic_type$ return_type)
                    (code.format (pre_walk_replace replacer body)))))

    {#AbstractMethod type_vars arg_decls return_type exs}
    (with_parens
      (spaced (list "abstract"
                    name
                    (privacy_modifier$ pm)
                    (with_brackets (spaced (list#each annotation$ anns)))
                    (with_brackets (spaced (list#each type_param$ type_vars)))
                    (with_brackets (spaced (list#each generic_type$ exs)))
                    (with_brackets (spaced (list#each arg_decl$ arg_decls)))
                    (generic_type$ return_type))))

    {#NativeMethod type_vars arg_decls return_type exs}
    (with_parens
      (spaced (list "native"
                    name
                    (privacy_modifier$ pm)
                    (with_brackets (spaced (list#each annotation$ anns)))
                    (with_brackets (spaced (list#each type_param$ type_vars)))
                    (with_brackets (spaced (list#each generic_type$ exs)))
                    (with_brackets (spaced (list#each arg_decl$ arg_decls)))
                    (generic_type$ return_type))))
    ))

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

... [Syntax]
(def: object_super_class
  Super_Class_Decl
  [#super_class_name   "java/lang/Object"
   #super_class_params (list)])

(syntax: .public (class: [im inheritance_modifier^
                          class_decl ..class_decl^
                          .let [full_class_name (product.left class_decl)]
                          .let [class_vars (product.right class_decl)]
                          super (<>.else object_super_class
                                         (..super_class_decl^ class_vars))
                          interfaces (<>.else (list)
                                              (<code>.tuple (<>.some (..super_class_decl^ class_vars))))
                          annotations ..annotations^
                          fields (<>.some (..field_decl^ class_vars))
                          methods (<>.some (..method_def^ class_vars))])
  (do meta.monad
    [current_module meta.current_module_name
     .let [fully_qualified_class_name (format (safe current_module) "." full_class_name)
           field_parsers (list#each (field_parser fully_qualified_class_name) fields)
           method_parsers (list#each (method_parser (product.right class_decl) fully_qualified_class_name) methods)
           replacer (parser_replacer (list#mix <>.either
                                               (<>.failure "")
                                               (list#composite field_parsers method_parsers)))
           def_code (format "jvm class:"
                            (spaced (list (class_decl$ class_decl)
                                          (super_class_decl$ super)
                                          (with_brackets (spaced (list#each super_class_decl$ interfaces)))
                                          (inheritance_modifier$ im)
                                          (with_brackets (spaced (list#each annotation$ annotations)))
                                          (with_brackets (spaced (list#each field_decl$ fields)))
                                          (with_brackets (spaced (list#each (method_def$ replacer super) methods))))))]]
    (in (list (` ((~ (code.text def_code))))))))

(syntax: .public (interface: [class_decl ..class_decl^
                              .let [class_vars (product.right class_decl)]
                              supers (<>.else (list)
                                              (<code>.tuple (<>.some (..super_class_decl^ class_vars))))
                              annotations ..annotations^
                              members (<>.some (..method_decl^ class_vars))])
  (let [def_code (format "jvm interface:"
                         (spaced (list (class_decl$ class_decl)
                                       (with_brackets (spaced (list#each super_class_decl$ supers)))
                                       (with_brackets (spaced (list#each annotation$ annotations)))
                                       (spaced (list#each method_decl$ members)))))]
    (in (list (` ((~ (code.text def_code))))))))

(syntax: .public (object [class_vars (<code>.tuple (<>.some ..type_param^))
                          super (<>.else object_super_class
                                         (..super_class_decl^ class_vars))
                          interfaces (<>.else (list)
                                              (<code>.tuple (<>.some (..super_class_decl^ class_vars))))
                          constructor_args (..constructor_args^ class_vars)
                          methods (<>.some ..overriden_method_def^)])
  (let [def_code (format "jvm anon-class:"
                         (spaced (list (super_class_decl$ super)
                                       (with_brackets (spaced (list#each super_class_decl$ interfaces)))
                                       (with_brackets (spaced (list#each constructor_arg$ constructor_args)))
                                       (with_brackets (spaced (list#each (method_def$ function.identity super) methods))))))]
    (in (list (` ((~ (code.text def_code))))))))

(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_symbols [g!temp]
    (in (list (` (let [(~ g!temp) (~ expr)]
                   (if ("jvm object null?" (~ g!temp))
                     {.#None}
                     {.#Some (~ g!temp)})))))))

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

                   {.#None}
                   ("jvm object null")))))))

(syntax: .public (as [class (..generic_type^ (list))
                      unchecked (<>.maybe <code>.any)])
  (with_symbols [g!_ g!unchecked]
    (let [class_name (simple_class$ (list) class)
          class_type (` (.Primitive (~ (code.text class_name))))
          check_type (` (.Maybe (~ class_type)))
          check_code (` (if ((~ (code.text (format "jvm instanceof" ":" class_name))) (~ g!unchecked))
                          {.#Some (.as (~ class_type)
                                       (~ g!unchecked))}
                          {.#None}))]
      (case unchecked
        {.#Some unchecked}
        (in (list (` (.is (~ check_type)
                          (let [(~ g!unchecked) (~ unchecked)]
                            (~ check_code))))))

        {.#None}
        (in (list (` (.is (-> (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_symbols [g!obj]
    (in (list (` (let [(~ g!obj) (~ obj)]
                   (exec (~+ (list#each (complete_call$ g!obj) methods))
                     (~ g!obj))))))))

(def: (class_import$ [full_name params])
  (-> Class_Declaration Code)
  (let [params' (list#each (|>> product.left code.local) params)]
    (template.with_locals [g!_]
      (` (def: (~ (code.symbol ["" full_name]))
           Type
           (All ((~ (' g!_)) (~+ params'))
             (Primitive (~ (code.text (safe full_name)))
                        [(~+ params')])))))))

(def: (member_type_vars class_tvars member)
  (-> (List Type_Parameter) Import_Member_Declaration (List Type_Parameter))
  (case member
    {#ConstructorDecl [commons _]}
    (list#composite class_tvars (the #import_member_tvars commons))

    {#MethodDecl [commons _]}
    (case (the #import_member_kind commons)
      {#StaticIMK}
      (the #import_member_tvars commons)

      _
      (list#composite class_tvars (the #import_member_tvars commons)))

    _
    class_tvars))

(def: (member_def_arg_bindings type_params class member)
  (-> (List Type_Parameter) Class_Declaration Import_Member_Declaration (Meta [(List [Bit Code]) (List Text) (List Code)]))
  (case member
    (^.or {#ConstructorDecl [commons _]} {#MethodDecl [commons _]})
    (let [(open "[0]") commons]
      (do [! meta.monad]
        [arg_inputs (monad.each !
                                (.is (-> [Bit GenericType] (Meta [Bit Code]))
                                     (function (_ [maybe? _])
                                       (with_symbols [arg_name]
                                         (in [maybe? arg_name]))))
                                #import_member_args)
         .let [arg_classes (.is (List Text)
                                (list#each (|>> product.right (simple_class$ (list#composite type_params #import_member_tvars)))
                                           #import_member_args))
               arg_types (list#each (.is (-> [Bit GenericType] Code)
                                         (function (_ [maybe? arg])
                                           (let [arg_type (class_type (the #import_member_mode commons) type_params arg)]
                                             (if maybe?
                                               (` (Maybe (~ arg_type)))
                                               arg_type))))
                                    #import_member_args)]]
        (in [arg_inputs arg_classes arg_types])))

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

(def: (decorate_return_maybe class member return_term)
  (-> Class_Declaration Import_Member_Declaration Code Code)
  (case member
    (^.or {#ConstructorDecl [commons _]} {#MethodDecl [commons _]})
    (if (the #import_member_maybe? commons)
      (` (??? (~ return_term)))
      (let [g!temp (` ((~' ~') (~ (code.symbol ["" " Ω "]))))]
        (` (let [(~ g!temp) (~ return_term)]
             (if (not (..null? (.as (Primitive "java.lang.Object")
                                    (~ g!temp))))
               (~ g!temp)
               (panic! (~ (code.text (format "Cannot produce null references from method calls @ "
                                             (the #class_name class)
                                             "." (the #import_member_alias commons))))))))))

    _
    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 (the <tag> commons)
         <term_trans>
         return_term)

       _
       return_term))]

  [decorate_return_try #import_member_try? (` (.try (~ return_term)))]
  [decorate_return_io  #import_member_io?  (` ((~! io.io) (~ return_term)))]
  )

(def: (free_type_param? [name bounds])
  (-> Type_Parameter Bit)
  (case bounds
    {.#End} #1
    _       #0))

(def: (lux_type_parameter [name _])
  (-> Type_Parameter Code)
  (code.symbol ["" name]))

(template [<name> <byte> <short> <int> <float>]
  [(def: (<name> mode [class expression])
     (-> Primitive_Mode [Text Code] Code)
     (case mode
       {#ManualPrM}
       expression
       
       {#AutoPrM}
       expression))]

  [auto_convert_input  long_to_byte long_to_short long_to_int double_to_float]
  [auto_convert_output byte_to_long short_to_long int_to_long float_to_double]
  )

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

(def: (jvm_extension_inputs mode classes inputs)
  (-> Primitive_Mode (List Text) (List [Bit Code]) (List Code))
  (|> inputs
      (list#each (function (_ [maybe? input])
                   (if maybe?
                     (` ((~! !!!) (~ (un_quote input))))
                     (un_quote input))))
      (list.zipped_2 classes)
      (list#each (auto_convert_input mode))))

(def: (import_name format class member)
  (-> Text Text Text Text)
  (|> format
      (text.replaced "[1]" class)
      (text.replaced "[0]" member)))

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

(def: (member_def_interop type_params kind class [arg_function_inputs arg_classes arg_types] member method_prefix import_format)
  (-> (List Type_Parameter) Class_Kind Class_Declaration [(List [Bit Code]) (List Text) (List Code)] Import_Member_Declaration Text Text (Meta (List Code)))
  (let [[full_name class_tvars] class
        full_name (safe full_name)
        all_params (|> (member_type_vars class_tvars member)
                       (list.only free_type_param?)
                       (list#each lux_type_parameter))]
    (case member
      {#EnumDecl enum_members}
      (macro.with_symbols [g!_]
        (do [! meta.monad]
          [.let [enum_type (.is Code
                                (case class_tvars
                                  {.#End}
                                  (` (Primitive (~ (code.text full_name))))

                                  _
                                  (let [=class_tvars (|> class_tvars
                                                         (list.only free_type_param?)
                                                         (list#each lux_type_parameter))]
                                    (` (All ((~ g!_) (~+ =class_tvars)) (Primitive (~ (code.text full_name)) [(~+ =class_tvars)]))))))
                 getter_interop (.is (-> Text Code)
                                     (function (_ name)
                                       (let [getter_name (code.symbol ["" (..import_name import_format method_prefix name)])]
                                         (` (def: (~ getter_name)
                                              (~ enum_type)
                                              ((~ (code.text (format "jvm getstatic" ":" full_name ":" name)))))))))]]
          (in (list#each getter_interop enum_members))))
      
      {#ConstructorDecl [commons _]}
      (do meta.monad
        [.let [def_name (code.symbol ["" (..import_name import_format method_prefix (the #import_member_alias commons))])
               jvm_extension (code.text (format "jvm new" ":" full_name ":" (text.interposed "," arg_classes)))
               jvm_interop (|> (` ((~ jvm_extension)
                                   (~+ (jvm_extension_inputs (the #import_member_mode commons) arg_classes arg_function_inputs))))
                               (decorate_return_maybe class member)
                               (decorate_return_try member)
                               (decorate_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_symbols [g!obj]
        (do meta.monad
          [.let [def_name (code.symbol ["" (..import_name import_format method_prefix (the #import_member_alias commons))])
                 (open "[0]") commons
                 (open "[0]") method
                 [jvm_op object_ast] (.is [Text (List Code)]
                                          (case #import_member_kind
                                            {#StaticIMK}
                                            ["invokestatic"
                                             (list)]

                                            {#VirtualIMK}
                                            (case kind
                                              {#Class}
                                              ["invokevirtual"
                                               (list g!obj)]
                                              
                                              {#Interface}
                                              ["invokeinterface"
                                               (list g!obj)]
                                              )))
                 jvm_extension (code.text (format "jvm " jvm_op ":" full_name ":" #import_method_name ":" (text.interposed "," arg_classes)))
                 jvm_interop (|> [(simple_class$ (list) (the #import_method_return method))
                                  (` ((~ jvm_extension) (~+ (list#each un_quote object_ast))
                                      (~+ (jvm_extension_inputs (the #import_member_mode commons) arg_classes arg_function_inputs))))]
                                 (auto_convert_output (the #import_member_mode commons))
                                 (decorate_return_maybe class member)
                                 (decorate_return_try member)
                                 (decorate_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 "[0]") fad
               base_gtype (class_type #import_field_mode type_params #import_field_type)
               classC (class_decl_type$ class)
               typeC (if #import_field_maybe?
                       (` (Maybe (~ base_gtype)))
                       base_gtype)
               tvar_asts (.is (List Code)
                              (|> class_tvars
                                  (list.only free_type_param?)
                                  (list#each lux_type_parameter)))
               getter_name (code.symbol ["" (..import_name import_format method_prefix #import_field_name)])
               setter_name (code.symbol ["" (..import_name import_format method_prefix (format #import_field_name "!"))])]
         getter_interop (with_symbols [g!obj]
                          (let [getter_call (if #import_field_static?
                                              (` ((~ getter_name) []))
                                              (` ((~ getter_name) [(~ g!obj) (~! <code>.any)])))
                                getter_body (<| (auto_convert_output #import_field_mode)
                                                [(simple_class$ (list) #import_field_type)
                                                 (if #import_field_static?
                                                   (let [jvm_extension (code.text (format "jvm getstatic" ":" full_name ":" #import_field_name))]
                                                     (` ((~ jvm_extension))))
                                                   (let [jvm_extension (code.text (format "jvm getfield" ":" full_name ":" #import_field_name))]
                                                     (` ((~ jvm_extension) (~ (un_quote 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 (.is (Meta (List Code))
                             (if #import_field_setter?
                               (with_symbols [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 (auto_convert_input #import_field_mode
                                                                        [(simple_class$ (list) #import_field_type) (un_quote g!value)])
                                       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+ (.is (List Code)
                                                   (if #import_field_static?
                                                     (list)
                                                     (list (un_quote g!obj))))]
                                   (in (list (` ((~! syntax:) (~ setter_call)
                                                 ((~' in) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value))))))))))))
                               (in (list))))]
        (in (partial_list getter_interop setter_interop)))
      )))

(def: (member_import$ type_params kind class [import_format member])
  (-> (List Type_Parameter) Class_Kind Class_Declaration [Text Import_Member_Declaration] (Meta (List Code)))
  (let [[method_prefix _] class]
    (do meta.monad
      [=args (member_def_arg_bindings type_params class member)]
      (member_def_interop type_params kind class =args member method_prefix import_format))))

(type: (java/lang/Class a)
  (Primitive "java.lang.Class" [a]))

(def: interface?
  (All (_ a) (-> (java/lang/Class a) Bit))
  (|>> "jvm invokevirtual:java.lang.Class:isInterface:"))

(def: (load_class class_name)
  (-> Text (Try (java/lang/Class Any)))
  (try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class_name)))

(def: (class_kind [class_name _])
  (-> Class_Declaration (Meta Class_Kind))
  (let [class_name (..safe class_name)]
    (case (..load_class class_name)
      {try.#Success class}
      (# meta.monad in (if (interface? class)
                         {#Interface}
                         {#Class}))

      {try.#Failure error}
      (meta.failure (format "Cannot load class: " class_name text.new_line
                            error)))))

(syntax: .public (import: [class_decl ..class_decl^
                           import_format <code>.text
                           members (<>.some (..import_member_decl^ (product.right class_decl)))])
  (do [! meta.monad]
    [kind (class_kind class_decl)
     =members (|> members
                  (list#each (|>> [import_format]))
                  (monad.each ! (member_import$ (product.right class_decl) kind class_decl)))]
    (in (partial_list (class_import$ class_decl) (list#conjoint =members)))))

(syntax: .public (array [type (..generic_type^ (list))
                         size <code>.any])
  (case type
    (^.template [<type> <array_op>]
      [(pattern {#GenericClass <type> (list)})
       (in (list (` (<array_op> (~ size)))))])
    (["boolean" "jvm znewarray"]
     ["byte"    "jvm bnewarray"]
     ["short"   "jvm snewarray"]
     ["int"     "jvm inewarray"]
     ["long"    "jvm lnewarray"]
     ["float"   "jvm fnewarray"]
     ["double"  "jvm dnewarray"]
     ["char"    "jvm cnewarray"])

    _
    (in (list (` ("jvm anewarray" (~ (code.text (generic_type$ type))) (~ size)))))))

(syntax: .public (length [array <code>.any])
  (in (list (` ("jvm arraylength" (~ array))))))

(def: (type_class_name type)
  (-> Type (Meta Text))
  (if (type#= Any type)
    (# meta.monad in "java.lang.Object")
    (case type
      {.#Primitive name params}
      (# meta.monad in name)

      {.#Apply A F}
      (case (type.applied (list A) F)
        {.#None}
        (meta.failure (format "Cannot apply type: " (type.format F) " to " (type.format A)))

        {.#Some type'}
        (type_class_name type'))
      
      {.#Named _ type'}
      (type_class_name type')

      _
      (meta.failure (format "Cannot convert to JvmType: " (type.format type))))))

(syntax: .public (read! [idx <code>.any
                         array <code>.any])
  (case array
    [_ {.#Symbol array_name}]
    (do meta.monad
      [array_type (meta.type array_name)
       array_jvm_type (type_class_name array_type)]
      (case array_jvm_type
        (^.template [<type> <array_op>]
          [<type>
           (in (list (` (<array_op> (~ array) (~ idx)))))])
        (["[Z" "jvm zaload"]
         ["[B" "jvm baload"]
         ["[S" "jvm saload"]
         ["[I" "jvm iaload"]
         ["[J" "jvm jaload"]
         ["[F" "jvm faload"]
         ["[D" "jvm daload"]
         ["[C" "jvm caload"])

        _
        (in (list (` ("jvm aaload" (~ array) (~ idx)))))))

    _
    (with_symbols [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
    [_ {.#Symbol array_name}]
    (do meta.monad
      [array_type (meta.type array_name)
       array_jvm_type (type_class_name array_type)]
      (case array_jvm_type
        (^.template [<type> <array_op>]
          [<type>
           (in (list (` (<array_op> (~ array) (~ idx) (~ value)))))])
        (["[Z" "jvm zastore"]
         ["[B" "jvm bastore"]
         ["[S" "jvm sastore"]
         ["[I" "jvm iastore"]
         ["[J" "jvm jastore"]
         ["[F" "jvm fastore"]
         ["[D" "jvm dastore"]
         ["[C" "jvm castore"])

        _
        (in (list (` ("jvm aastore" (~ array) (~ idx) (~ value)))))))

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

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

(syntax: .public (type [type (..generic_type^ (list))])
  (in (list (..class_type {#ManualPrM} (list) type))))

(template: .public (is type term)
  [(.as type term)])