path: root/stdlib/source/lux/host.old.lux

(.module:
  [lux (#- type)
   [abstract
    ["." monad (#+ Monad do)]
    ["." enum]]
   [control
    ["." function]
    ["." io]
    ["p" parser
     ["s" code (#+ Parser)]]]
   [data
    ["." maybe]
    ["." product]
    ["." error (#+ Error)]
    ["." bit ("#@." codec)]
    number
    ["." text ("#@." equivalence monoid)
     format]
    [collection
     ["." array (#+ Array)]
     ["." list ("#@." monad fold monoid)]]]
   ["." type ("#@." equivalence)]
   ["." macro (#+ with-gensyms)
    ["." code]
    [syntax (#+ syntax:)]]])

(template [<name> <op> <from> <to>]
  [(def: #export (<name> value)
     {#.doc (doc "Type converter."
                 (: <to>
                    (<name> (: <from> foo))))}
     (-> (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"]
  )

## [Utils]
(def: constructor-method-name "<init>")
(def: member-separator "::")

## Types
(type: JVM-Code Text)

(type: BoundKind
  #UpperBound
  #LowerBound)

(type: #rec GenericType
  (#GenericTypeVar Text)
  (#GenericClass [Text (List GenericType)])
  (#GenericArray GenericType)
  (#GenericWildcard (Maybe [BoundKind GenericType])))

(type: Type-Parameter
  [Text (List GenericType)])

(type: Primitive-Mode
  #ManualPrM
  #AutoPrM)

(type: PrivacyModifier
  #PublicPM
  #PrivatePM
  #ProtectedPM
  #DefaultPM)

(type: StateModifier
  #VolatileSM
  #FinalSM
  #DefaultSM)

(type: InheritanceModifier
  #FinalIM
  #AbstractIM
  #DefaultIM)

(type: Class-Kind
  #Class
  #Interface)

(type: Class-Declaration
  {#class-name   Text
   #class-params (List Type-Parameter)})

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

(type: Super-Class-Decl
  {#super-class-name   Text
   #super-class-params (List GenericType)})

(type: AnnotationParam
  [Text Code])

(type: Annotation
  {#ann-name   Text
   #ann-params (List AnnotationParam)})

(type: Member-Declaration
  {#member-name Text
   #member-privacy PrivacyModifier
   #member-anns (List Annotation)})

(type: FieldDecl
  (#ConstantField GenericType Code)
  (#VariableField StateModifier GenericType))

(type: MethodDecl
  {#method-tvars  (List Type-Parameter)
   #method-inputs (List GenericType)
   #method-output GenericType
   #method-exs    (List GenericType)})

(type: ArgDecl
  {#arg-name Text
   #arg-type GenericType})

(type: ConstructorArg
  [GenericType Code])

(type: Method-Definition
  (#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
  {#pc-method Name
   #pc-args   (List Code)})

(type: ImportMethodKind
  #StaticIMK
  #VirtualIMK)

(type: ImportMethodCommons
  {#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
  {})

(type: ImportMethodDecl
  {#import-method-name    Text
   #import-method-return  GenericType})

(type: ImportFieldDecl
  {#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
  (#EnumDecl        (List Text))
  (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl])
  (#MethodDecl      [ImportMethodCommons ImportMethodDecl])
  (#FieldAccessDecl ImportFieldDecl))

(type: Class-Imports
  (List [Text Text]))

## Utils
(def: (short-class-name name)
  (-> Text Text)
  (case (list.reverse (text.split-all-with "/" name))
    (#.Cons short-name _)
    short-name

    #.Nil
    name))

(def: (manual-primitive-to-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-to-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: sanitize
  (-> Text Text)
  (text.replace-all "/" "."))

(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 #.Nil] #ManualPrM #0]
            [(manual-primitive-to-type prim) (#.Some output)])
    output

    (^multi [[prim #.Nil] #AutoPrM #0]
            [(auto-primitive-to-type prim) (#.Some output)])
    output
    
    [[name params] _ _]
    (let [name (sanitize name)
          =params (list@map (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.find (function (_ [pname pbounds])
                       (and (text@= name pname)
                            (not (list.empty? pbounds))))
                     type-params)
      #.None
      (code.identifier ["" name])

      (#.Some [pname pbounds])
      (class->type' mode type-params in-array? (maybe.assume (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.identifier ["" name]))

(def: (class-decl-type$ (^slots [#class-name #class-params]))
  (-> Class-Declaration Code)
  (let [=params (list@map (: (-> Type-Parameter Code)
                             (function (_ [pname pbounds])
                               (case pbounds
                                 #.Nil
                                 (code.identifier ["" pname])

                                 (#.Cons bound1 _)
                                 (class->type #ManualPrM class-params bound1))))
                          class-params)]
    (` (primitive (~ (code.text (sanitize class-name)))
                  [(~+ =params)]))))

(def: empty-imports
  Class-Imports
  (list))

(def: (get-import name imports)
  (-> Text Class-Imports (Maybe Text))
  (:: maybe.functor map product.right
      (list.find (|>> product.left (text@= name))
                 imports)))

(def: (add-import short+full imports)
  (-> [Text Text] Class-Imports Class-Imports)
  (#.Cons short+full imports))

(def: (class-imports compiler)
  (-> Lux Class-Imports)
  (case (macro.run compiler
                   (: (Meta Class-Imports)
                      (do macro.monad
                        [current-module macro.current-module-name
                         definitions (macro.definitions current-module)]
                        (wrap (list@fold (: (-> [Text Definition] Class-Imports Class-Imports)
                                            (function (_ [short-name [_ _ meta _]] imports)
                                              (case (macro.get-text-ann (name-of #..jvm-class) meta)
                                                (#.Some full-class-name)
                                                (add-import [short-name full-class-name] imports)

                                                _
                                                imports)))
                                         empty-imports
                                         definitions)))))
    (#.Left _)        (list)
    (#.Right imports) imports))

(def: java/lang/*
  (List Text)
  (list ## Interfaces
   "Appendable"
   "AutoCloseable"
   "CharSequence"
   "Cloneable"
   "Comparable"
   "Iterable"
   "Readable"
   "Runnable"

   ## Classes
   "Boolean"
   "Byte"
   "Character"
   "Class"
   "ClassLoader"
   "ClassValue"
   "Compiler"
   "Double"
   "Enum"
   "Float"
   "InheritableThreadLocal"
   "Integer"
   "Long"
   "Math"
   "Number"
   "Object"
   "Package"
   "Process"
   "ProcessBuilder"
   "Runtime"
   "RuntimePermission"
   "SecurityManager"
   "Short"
   "StackTraceElement"
   "StrictMath"
   "String"
   "StringBuffer"
   "StringBuilder"
   "System"
   "Thread"
   "ThreadGroup"
   "ThreadLocal"
   "Throwable"
   "Void"

   ## Exceptions
   "ArithmeticException"
   "ArrayIndexOutOfBoundsException"
   "ArrayStoreException"
   "ClassCastException"
   "ClassNotFoundException"
   "CloneNotSupportedException"
   "EnumConstantNotPresentException"
   "Exception"
   "IllegalAccessException"
   "IllegalArgumentException"
   "IllegalMonitorStateException"
   "IllegalStateException"
   "IllegalThreadStateException"
   "IndexOutOfBoundsException"
   "InstantiationException"
   "InterruptedException"
   "NegativeArraySizeException"
   "NoSuchFieldException"
   "NoSuchMethodException"
   "NullPointerException"
   "NumberFormatException"
   "ReflectiveOperationException"
   "RuntimeException"
   "SecurityException"
   "StringIndexOutOfBoundsException"
   "TypeNotPresentException"
   "UnsupportedOperationException"

   ## Annotations
   "Deprecated"
   "Override"
   "SafeVarargs"
   "SuppressWarnings"))

(def: (qualify imports name)
  (-> Class-Imports Text Text)
  (if (list.member? text.equivalence java/lang/* name)
    (format "java/lang/" name)
    (maybe.default name (get-import name imports))))

(def: type-var-class Text "java.lang.Object")

(def: (simple-class$ env class)
  (-> (List Type-Parameter) GenericType Text)
  (case class
    (#GenericTypeVar name)
    (case (list.find (function (_ [pname pbounds])
                       (and (text@= name pname)
                            (not (list.empty? pbounds))))
                     env)
      #.None
      type-var-class

      (#.Some [pname pbounds])
      (simple-class$ env (maybe.assume (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)
    (sanitize name)

    (#GenericArray param')
    (case param'
      (#GenericArray param)
      (format "[" (simple-class$ env param))
      
      (^template [<prim> <class>]
        (#GenericClass <prim> #.Nil)
        <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: (make-get-const-parser class-name field-name)
  (-> Text Text (Parser Code))
  (do p.monad
    [#let [dotted-name (format "::" field-name)]
     _ (s.this! (code.identifier ["" dotted-name]))]
    (wrap (`' ((~ (code.text (format "jvm getstatic" ":" class-name ":" field-name))))))))

(def: (make-get-var-parser class-name field-name)
  (-> Text Text (Parser Code))
  (do p.monad
    [#let [dotted-name (format "::" field-name)]
     _ (s.this! (code.identifier ["" dotted-name]))]
    (wrap (`' ((~ (code.text (format "jvm getfield" ":" class-name ":" field-name))) _jvm_this)))))

(def: (make-put-var-parser class-name field-name)
  (-> Text Text (Parser Code))
  (do p.monad
    [#let [dotted-name (format "::" field-name)]
     [_ _ value] (: (Parser [Any Any Code])
                    (s.form ($_ p.and (s.this! (' :=)) (s.this! (code.identifier ["" dotted-name])) s.any)))]
    (wrap (`' ((~ (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@map (pre-walk-replace f) parts))])
    ([#.Form]
     [#.Tuple])
    
    [meta (#.Record pairs)]
    [meta (#.Record (list@map (: (-> [Code Code] [Code Code])
                                 (function (_ [key val])
                                   [(pre-walk-replace f key) (pre-walk-replace f val)]))
                              pairs))]
    
    ast'
    ast'))

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

    _
    ast
    ))

(def: (field->parser class-name [[field-name _ _] field])
  (-> Text [Member-Declaration FieldDecl] (Parser Code))
  (case field
    (#ConstantField _)
    (make-get-const-parser class-name field-name)
    
    (#VariableField _)
    (p.either (make-get-var-parser class-name field-name)
              (make-put-var-parser class-name field-name))))

(def: (make-constructor-parser params class-name arg-decls)
  (-> (List Type-Parameter) Text (List ArgDecl) (Parser Code))
  (do p.monad
    [args (: (Parser (List Code))
             (s.form (p.after (s.this! (' ::new!))
                              (s.tuple (p.exactly (list.size arg-decls) s.any)))))
     #let [arg-decls' (: (List Text) (list@map (|>> product.right (simple-class$ params)) arg-decls))]]
    (wrap (` ((~ (code.text (format "jvm new" ":" class-name ":" (text.join-with "," arg-decls'))))
              (~+ args))))))

(def: (make-static-method-parser params class-name method-name arg-decls)
  (-> (List Type-Parameter) Text Text (List ArgDecl) (Parser Code))
  (do p.monad
    [#let [dotted-name (format "::" method-name "!")]
     args (: (Parser (List Code))
             (s.form (p.after (s.this! (code.identifier ["" dotted-name]))
                              (s.tuple (p.exactly (list.size arg-decls) s.any)))))
     #let [arg-decls' (: (List Text) (list@map (|>> product.right (simple-class$ params)) arg-decls))]]
    (wrap (`' ((~ (code.text (format "jvm invokestatic" ":" class-name ":" method-name ":" (text.join-with "," 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 p.monad
       [#let [dotted-name (format "::" method-name "!")]
        args (: (Parser (List Code))
                (s.form (p.after (s.this! (code.identifier ["" dotted-name]))
                                 (s.tuple (p.exactly (list.size arg-decls) s.any)))))
        #let [arg-decls' (: (List Text) (list@map (|>> product.right (simple-class$ params)) arg-decls))]]
       (wrap (`' ((~ (code.text (format <jvm-op> ":" class-name ":" method-name ":" (text.join-with "," arg-decls'))))
                  (~' _jvm_this) (~+ args))))))]

  [make-special-method-parser "jvm invokespecial"]
  [make-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)
    (make-constructor-parser params class-name args)
    
    (#StaticMethod strict? type-vars args return-type return-expr exs)
    (make-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))
    (make-special-method-parser params class-name method-name args)

    (#AbstractMethod type-vars args return-type exs)
    (make-virtual-method-parser params class-name method-name args)

    (#NativeMethod type-vars args return-type exs)
    (make-virtual-method-parser params class-name method-name args)))

## Parsers
(def: (full-class-name^ imports)
  (-> Class-Imports (Parser Text))
  (do p.monad
    [name s.local-identifier]
    (wrap (qualify imports name))))

(def: privacy-modifier^
  (Parser PrivacyModifier)
  (let [(^open ".") p.monad]
    ($_ p.or
        (s.this! (' #public))
        (s.this! (' #private))
        (s.this! (' #protected))
        (wrap []))))

(def: inheritance-modifier^
  (Parser InheritanceModifier)
  (let [(^open ".") p.monad]
    ($_ p.or
        (s.this! (' #final))
        (s.this! (' #abstract))
        (wrap []))))

(def: bound-kind^
  (Parser BoundKind)
  (p.or (s.this! (' <))
        (s.this! (' >))))

(def: (assert-no-periods name)
  (-> Text (Parser Any))
  (p.assert "Names in class declarations cannot contain periods."
            (not (text.contains? "." name))))

(def: (generic-type^ imports type-vars)
  (-> Class-Imports (List Type-Parameter) (Parser GenericType))
  ($_ p.either
      (do p.monad
        [_ (s.this! (' ?))]
        (wrap (#GenericWildcard #.None)))
      (s.tuple (do p.monad
                 [_ (s.this! (' ?))
                  bound-kind bound-kind^
                  bound (generic-type^ imports type-vars)]
                 (wrap (#GenericWildcard (#.Some [bound-kind bound])))))
      (do p.monad
        [name (full-class-name^ imports)
         _ (assert-no-periods name)]
        (if (list.member? text.equivalence (list@map product.left type-vars) name)
          (wrap (#GenericTypeVar name))
          (wrap (#GenericClass name (list)))))
      (s.form (do p.monad
                [name (s.this! (' Array))
                 component (generic-type^ imports type-vars)]
                (case component
                  (^template [<class> <name>]
                    (#GenericClass <name> #.Nil)
                    (wrap (#GenericClass <class> (list))))
                  (["[Z" "boolean"]
                   ["[B" "byte"]
                   ["[S" "short"]
                   ["[I" "int"]
                   ["[J" "long"]
                   ["[F" "float"]
                   ["[D" "double"]
                   ["[C" "char"])

                  _
                  (wrap (#GenericArray component)))))
      (s.form (do p.monad
                [name (full-class-name^ imports)
                 _ (assert-no-periods name)
                 params (p.some (generic-type^ imports type-vars))
                 _ (p.assert (format name " cannot be a type-parameter!")
                             (not (list.member? text.equivalence (list@map product.left type-vars) name)))]
                (wrap (#GenericClass name params))))
      ))

(def: (type-param^ imports)
  (-> Class-Imports (Parser Type-Parameter))
  (p.either (do p.monad
              [param-name s.local-identifier]
              (wrap [param-name (list)]))
            (s.tuple (do p.monad
                       [param-name s.local-identifier
                        _ (s.this! (' <))
                        bounds (p.many (generic-type^ imports (list)))]
                       (wrap [param-name bounds])))))

(def: (type-params^ imports)
  (-> Class-Imports (Parser (List Type-Parameter)))
  (s.tuple (p.some (type-param^ imports))))

(def: (class-decl^ imports)
  (-> Class-Imports (Parser Class-Declaration))
  (p.either (do p.monad
              [name (full-class-name^ imports)
               _ (assert-no-periods name)]
              (wrap [name (list)]))
            (s.form (do p.monad
                      [name (full-class-name^ imports)
                       _ (assert-no-periods name)
                       params (p.some (type-param^ imports))]
                      (wrap [name params])))
            ))

(def: (super-class-decl^ imports type-vars)
  (-> Class-Imports (List Type-Parameter) (Parser Super-Class-Decl))
  (p.either (do p.monad
              [name (full-class-name^ imports)
               _ (assert-no-periods name)]
              (wrap [name (list)]))
            (s.form (do p.monad
                      [name (full-class-name^ imports)
                       _ (assert-no-periods name)
                       params (p.some (generic-type^ imports type-vars))]
                      (wrap [name params])))))

(def: annotation-params^
  (Parser (List AnnotationParam))
  (s.record (p.some (p.and s.local-tag s.any))))

(def: (annotation^ imports)
  (-> Class-Imports (Parser Annotation))
  (p.either (do p.monad
              [ann-name (full-class-name^ imports)]
              (wrap [ann-name (list)]))
            (s.form (p.and (full-class-name^ imports)
                           annotation-params^))))

(def: (annotations^' imports)
  (-> Class-Imports (Parser (List Annotation)))
  (do p.monad
    [_ (s.this! (' #ann))]
    (s.tuple (p.some (annotation^ imports)))))

(def: (annotations^ imports)
  (-> Class-Imports (Parser (List Annotation)))
  (do p.monad
    [anns?? (p.maybe (annotations^' imports))]
    (wrap (maybe.default (list) anns??))))

(def: (throws-decl'^ imports type-vars)
  (-> Class-Imports (List Type-Parameter) (Parser (List GenericType)))
  (do p.monad
    [_ (s.this! (' #throws))]
    (s.tuple (p.some (generic-type^ imports type-vars)))))

(def: (throws-decl^ imports type-vars)
  (-> Class-Imports (List Type-Parameter) (Parser (List GenericType)))
  (do p.monad
    [exs? (p.maybe (throws-decl'^ imports type-vars))]
    (wrap (maybe.default (list) exs?))))

(def: (method-decl^ imports type-vars)
  (-> Class-Imports (List Type-Parameter) (Parser [Member-Declaration MethodDecl]))
  (s.form (do p.monad
            [tvars (p.default (list) (type-params^ imports))
             name s.local-identifier
             anns (annotations^ imports)
             inputs (s.tuple (p.some (generic-type^ imports type-vars)))
             output (generic-type^ imports type-vars)
             exs (throws-decl^ imports type-vars)]
            (wrap [[name #PublicPM anns] {#method-tvars tvars
                                          #method-inputs inputs
                                          #method-output output
                                          #method-exs    exs}]))))

(def: state-modifier^
  (Parser StateModifier)
  ($_ p.or
      (s.this! (' #volatile))
      (s.this! (' #final))
      (:: p.monad wrap [])))

(def: (field-decl^ imports type-vars)
  (-> Class-Imports (List Type-Parameter) (Parser [Member-Declaration FieldDecl]))
  (p.either (s.form (do p.monad
                      [_ (s.this! (' #const))
                       name s.local-identifier
                       anns (annotations^ imports)
                       type (generic-type^ imports type-vars)
                       body s.any]
                      (wrap [[name #PublicPM anns] (#ConstantField [type body])])))
            (s.form (do p.monad
                      [pm privacy-modifier^
                       sm state-modifier^
                       name s.local-identifier
                       anns (annotations^ imports)
                       type (generic-type^ imports type-vars)]
                      (wrap [[name pm anns] (#VariableField [sm type])])))))

(def: (arg-decl^ imports type-vars)
  (-> Class-Imports (List Type-Parameter) (Parser ArgDecl))
  (s.record (p.and s.local-identifier
                   (generic-type^ imports type-vars))))

(def: (arg-decls^ imports type-vars)
  (-> Class-Imports (List Type-Parameter) (Parser (List ArgDecl)))
  (p.some (arg-decl^ imports type-vars)))

(def: (constructor-arg^ imports type-vars)
  (-> Class-Imports (List Type-Parameter) (Parser ConstructorArg))
  (s.record (p.and (generic-type^ imports type-vars) s.any)))

(def: (constructor-args^ imports type-vars)
  (-> Class-Imports (List Type-Parameter) (Parser (List ConstructorArg)))
  (s.tuple (p.some (constructor-arg^ imports type-vars))))

(def: (constructor-method^ imports class-vars)
  (-> Class-Imports (List Type-Parameter) (Parser [Member-Declaration Method-Definition]))
  (s.form (do p.monad
            [pm privacy-modifier^
             strict-fp? (p.parses? (s.this! (' #strict)))
             method-vars (p.default (list) (type-params^ imports))
             #let [total-vars (list@compose class-vars method-vars)]
             [_ arg-decls] (s.form (p.and (s.this! (' new))
                                          (arg-decls^ imports total-vars)))
             constructor-args (constructor-args^ imports total-vars)
             exs (throws-decl^ imports total-vars)
             annotations (annotations^ imports)
             body s.any]
            (wrap [{#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^ imports class-vars)
  (-> Class-Imports (List Type-Parameter) (Parser [Member-Declaration Method-Definition]))
  (s.form (do p.monad
            [pm privacy-modifier^
             strict-fp? (p.parses? (s.this! (' #strict)))
             final? (p.parses? (s.this! (' #final)))
             method-vars (p.default (list) (type-params^ imports))
             #let [total-vars (list@compose class-vars method-vars)]
             [name this-name arg-decls] (s.form ($_ p.and
                                                    s.local-identifier
                                                    s.local-identifier
                                                    (arg-decls^ imports total-vars)))
             return-type (generic-type^ imports total-vars)
             exs (throws-decl^ imports total-vars)
             annotations (annotations^ imports)
             body s.any]
            (wrap [{#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^ imports)
  (-> Class-Imports (Parser [Member-Declaration Method-Definition]))
  (s.form (do p.monad
            [strict-fp? (p.parses? (s.this! (' #strict)))
             owner-class (class-decl^ imports)
             method-vars (p.default (list) (type-params^ imports))
             #let [total-vars (list@compose (product.right owner-class) method-vars)]
             [name this-name arg-decls] (s.form ($_ p.and
                                                    s.local-identifier
                                                    s.local-identifier
                                                    (arg-decls^ imports total-vars)))
             return-type (generic-type^ imports total-vars)
             exs (throws-decl^ imports total-vars)
             annotations (annotations^ imports)
             body s.any]
            (wrap [{#member-name name
                    #member-privacy #PublicPM
                    #member-anns annotations}
                   (#OverridenMethod strict-fp?
                                     owner-class method-vars
                                     this-name arg-decls return-type
                                     body exs)]))))

(def: (static-method-def^ imports)
  (-> Class-Imports (Parser [Member-Declaration Method-Definition]))
  (s.form (do p.monad
            [pm privacy-modifier^
             strict-fp? (p.parses? (s.this! (' #strict)))
             _ (s.this! (' #static))
             method-vars (p.default (list) (type-params^ imports))
             #let [total-vars method-vars]
             [name arg-decls] (s.form (p.and s.local-identifier
                                             (arg-decls^ imports total-vars)))
             return-type (generic-type^ imports total-vars)
             exs (throws-decl^ imports total-vars)
             annotations (annotations^ imports)
             body s.any]
            (wrap [{#member-name name
                    #member-privacy pm
                    #member-anns annotations}
                   (#StaticMethod strict-fp? method-vars arg-decls return-type body exs)]))))

(def: (abstract-method-def^ imports)
  (-> Class-Imports (Parser [Member-Declaration Method-Definition]))
  (s.form (do p.monad
            [pm privacy-modifier^
             _ (s.this! (' #abstract))
             method-vars (p.default (list) (type-params^ imports))
             #let [total-vars method-vars]
             [name arg-decls] (s.form (p.and s.local-identifier
                                             (arg-decls^ imports total-vars)))
             return-type (generic-type^ imports total-vars)
             exs (throws-decl^ imports total-vars)
             annotations (annotations^ imports)]
            (wrap [{#member-name name
                    #member-privacy pm
                    #member-anns annotations}
                   (#AbstractMethod method-vars arg-decls return-type exs)]))))

(def: (native-method-def^ imports)
  (-> Class-Imports (Parser [Member-Declaration Method-Definition]))
  (s.form (do p.monad
            [pm privacy-modifier^
             _ (s.this! (' #native))
             method-vars (p.default (list) (type-params^ imports))
             #let [total-vars method-vars]
             [name arg-decls] (s.form (p.and s.local-identifier
                                             (arg-decls^ imports total-vars)))
             return-type (generic-type^ imports total-vars)
             exs (throws-decl^ imports total-vars)
             annotations (annotations^ imports)]
            (wrap [{#member-name name
                    #member-privacy pm
                    #member-anns annotations}
                   (#NativeMethod method-vars arg-decls return-type exs)]))))

(def: (method-def^ imports class-vars)
  (-> Class-Imports (List Type-Parameter) (Parser [Member-Declaration Method-Definition]))
  ($_ p.either
      (constructor-method^ imports class-vars)
      (virtual-method-def^ imports class-vars)
      (overriden-method-def^ imports)
      (static-method-def^ imports)
      (abstract-method-def^ imports)
      (native-method-def^ imports)))

(def: partial-call^
  (Parser Partial-Call)
  (s.form (p.and s.identifier (p.some s.any))))

(def: class-kind^
  (Parser Class-Kind)
  (p.either (do p.monad
              [_ (s.this! (' #class))]
              (wrap #Class))
            (do p.monad
              [_ (s.this! (' #interface))]
              (wrap #Interface))
            ))

(def: import-member-alias^
  (Parser (Maybe Text))
  (p.maybe (do p.monad
             [_ (s.this! (' #as))]
             s.local-identifier)))

(def: (import-member-args^ imports type-vars)
  (-> Class-Imports (List Type-Parameter) (Parser (List [Bit GenericType])))
  (s.tuple (p.some (p.and (p.parses? (s.this! (' #?))) (generic-type^ imports type-vars)))))

(def: import-member-return-flags^
  (Parser [Bit Bit Bit])
  ($_ p.and (p.parses? (s.this! (' #io))) (p.parses? (s.this! (' #try))) (p.parses? (s.this! (' #?)))))

(def: primitive-mode^
  (Parser Primitive-Mode)
  (p.or (s.this! (' #manual))
        (s.this! (' #auto))))

(def: (import-member-decl^ imports owner-vars)
  (-> Class-Imports (List Type-Parameter) (Parser Import-Member-Declaration))
  ($_ p.either
      (s.form (do p.monad
                [_ (s.this! (' #enum))
                 enum-members (p.some s.local-identifier)]
                (wrap (#EnumDecl enum-members))))
      (s.form (do p.monad
                [tvars (p.default (list) (type-params^ imports))
                 _ (s.this! (' new))
                 ?alias import-member-alias^
                 #let [total-vars (list@compose owner-vars tvars)]
                 ?prim-mode (p.maybe primitive-mode^)
                 args (import-member-args^ imports total-vars)
                 [io? try? maybe?] import-member-return-flags^]
                (wrap (#ConstructorDecl [{#import-member-mode    (maybe.default #AutoPrM ?prim-mode)
                                          #import-member-alias   (maybe.default "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?}
                                         {}]))
                ))
      (s.form (do p.monad
                [kind (: (Parser ImportMethodKind)
                         (p.or (s.this! (' #static))
                               (wrap [])))
                 tvars (p.default (list) (type-params^ imports))
                 name s.local-identifier
                 ?alias import-member-alias^
                 #let [total-vars (list@compose owner-vars tvars)]
                 ?prim-mode (p.maybe primitive-mode^)
                 args (import-member-args^ imports total-vars)
                 [io? try? maybe?] import-member-return-flags^
                 return (generic-type^ imports total-vars)]
                (wrap (#MethodDecl [{#import-member-mode    (maybe.default #AutoPrM ?prim-mode)
                                     #import-member-alias   (maybe.default 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
                                     }]))))
      (s.form (do p.monad
                [static? (p.parses? (s.this! (' #static)))
                 name s.local-identifier
                 ?prim-mode (p.maybe primitive-mode^)
                 gtype (generic-type^ imports owner-vars)
                 maybe? (p.parses? (s.this! (' #?)))
                 setter? (p.parses? (s.this! (' #!)))]
                (wrap (#FieldAccessDecl {#import-field-mode    (maybe.default #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.enclose ["(" ")"]))

(def: with-brackets
  (-> JVM-Code JVM-Code)
  (text.enclose ["[" "]"]))

(def: spaced
  (-> (List JVM-Code) JVM-Code)
  (text.join-with " "))

(def: (privacy-modifier$ pm)
  (-> PrivacyModifier JVM-Code)
  (case pm
    #PublicPM    "public"
    #PrivatePM   "private"
    #ProtectedPM "protected"
    #DefaultPM   "default"))

(def: (inheritance-modifier$ im)
  (-> InheritanceModifier JVM-Code)
  (case im
    #FinalIM    "final"
    #AbstractIM "abstract"
    #DefaultIM  "default"))

(def: (annotation-param$ [name value])
  (-> AnnotationParam JVM-Code)
  (format name "=" (code.to-text value)))

(def: (annotation$ [name params])
  (-> Annotation JVM-Code)
  (format "(" name " " "{" (text.join-with text.tab (list@map 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 "(" (sanitize name) " " (spaced (list@map 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@map generic-type$ bounds)) ")"))

(def: (class-decl$ (^open "."))
  (-> Class-Declaration JVM-Code)
  (format "(" (sanitize class-name) " " (spaced (list@map type-param$ class-params)) ")"))

(def: (super-class-decl$ (^slots [#super-class-name #super-class-params]))
  (-> Super-Class-Decl JVM-Code)
  (format "(" (sanitize super-class-name) " " (spaced (list@map generic-type$ super-class-params)) ")"))

(def: (method-decl$ [[name pm anns] method-decl])
  (-> [Member-Declaration MethodDecl] JVM-Code)
  (let [(^slots [#method-tvars #method-inputs #method-output #method-exs]) method-decl]
    (with-parens
      (spaced (list name
                    (with-brackets (spaced (list@map annotation$ anns)))
                    (with-brackets (spaced (list@map type-param$ method-tvars)))
                    (with-brackets (spaced (list@map generic-type$ method-exs)))
                    (with-brackets (spaced (list@map generic-type$ method-inputs)))
                    (generic-type$ method-output))
              ))))

(def: (state-modifier$ sm)
  (-> StateModifier JVM-Code)
  (case sm
    #VolatileSM "volatile"
    #FinalSM    "final"
    #DefaultSM  "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@map annotation$ anns)))
                    (generic-type$ class)
                    (code.to-text value))
              ))

    (#VariableField sm class)
    (with-parens
      (spaced (list "variable" name
                    (privacy-modifier$ pm)
                    (state-modifier$ sm)
                    (with-brackets (spaced (list@map 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.to-text 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@encode strict-fp?)
                    (with-brackets (spaced (list@map annotation$ anns)))
                    (with-brackets (spaced (list@map type-param$ type-vars)))
                    (with-brackets (spaced (list@map generic-type$ exs)))
                    (with-brackets (spaced (list@map arg-decl$ arg-decls)))
                    (with-brackets (spaced (list@map constructor-arg$ constructor-args)))
                    (code.to-text (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@encode final?)
                    (bit@encode strict-fp?)
                    (with-brackets (spaced (list@map annotation$ anns)))
                    (with-brackets (spaced (list@map type-param$ type-vars)))
                    (with-brackets (spaced (list@map generic-type$ exs)))
                    (with-brackets (spaced (list@map arg-decl$ arg-decls)))
                    (generic-type$ return-type)
                    (code.to-text (pre-walk-replace replacer (` (let [(~ (code.local-identifier 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 (s.form (do p.monad
                                                     [_ (s.this! (' ::super!))
                                                      args (s.tuple (p.exactly (list.size arg-decls) s.any))
                                                      #let [arg-decls' (: (List Text) (list@map (|>> product.right (simple-class$ (list)))
                                                                                                arg-decls))]]
                                                     (wrap (`' ((~ (code.text (format "jvm invokespecial"
                                                                                      ":" (get@ #super-class-name super-class)
                                                                                      ":" name
                                                                                      ":" (text.join-with "," arg-decls'))))
                                                                (~' _jvm_this) (~+ args)))))))]
      (with-parens
        (spaced (list "override"
                      (class-decl$ class-decl)
                      name
                      (bit@encode strict-fp?)
                      (with-brackets (spaced (list@map annotation$ anns)))
                      (with-brackets (spaced (list@map type-param$ type-vars)))
                      (with-brackets (spaced (list@map generic-type$ exs)))
                      (with-brackets (spaced (list@map arg-decl$ arg-decls)))
                      (generic-type$ return-type)
                      (|> (` (let [(~ (code.local-identifier this-name)) (~' _jvm_this)]
                               (~ body)))
                          (pre-walk-replace replacer)
                          (pre-walk-replace super-replacer)
                          (code.to-text))
                      ))))

    (#StaticMethod strict-fp? type-vars arg-decls return-type body exs)
    (with-parens
      (spaced (list "static"
                    name
                    (privacy-modifier$ pm)
                    (bit@encode strict-fp?)
                    (with-brackets (spaced (list@map annotation$ anns)))
                    (with-brackets (spaced (list@map type-param$ type-vars)))
                    (with-brackets (spaced (list@map generic-type$ exs)))
                    (with-brackets (spaced (list@map arg-decl$ arg-decls)))
                    (generic-type$ return-type)
                    (code.to-text (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@map annotation$ anns)))
                    (with-brackets (spaced (list@map type-param$ type-vars)))
                    (with-brackets (spaced (list@map generic-type$ exs)))
                    (with-brackets (spaced (list@map 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@map annotation$ anns)))
                    (with-brackets (spaced (list@map type-param$ type-vars)))
                    (with-brackets (spaced (list@map generic-type$ exs)))
                    (with-brackets (spaced (list@map arg-decl$ arg-decls)))
                    (generic-type$ return-type))))
    ))

(def: (complete-call$ g!obj [method args])
  (-> Code Partial-Call Code)
  (` ((~ (code.identifier method)) (~+ args) (~ g!obj))))

## [Syntax]
(def: object-super-class
  Super-Class-Decl
  {#super-class-name   "java/lang/Object"
   #super-class-params (list)})

(syntax: #export (class:
                   {#let [imports (class-imports *compiler*)]}
                   {im inheritance-modifier^}
                   {class-decl (class-decl^ imports)}
                   {#let [full-class-name (product.left class-decl)
                          imports (add-import [(short-class-name full-class-name) full-class-name]
                                              (class-imports *compiler*))]}
                   {#let [class-vars (product.right class-decl)]}
                   {super (p.default object-super-class
                                     (super-class-decl^ imports class-vars))}
                   {interfaces (p.default (list)
                                          (s.tuple (p.some (super-class-decl^ imports class-vars))))}
                   {annotations (annotations^ imports)}
                   {fields (p.some (field-decl^ imports class-vars))}
                   {methods (p.some (method-def^ imports class-vars))})
  {#.doc (doc "Allows defining JVM classes in Lux code."
              "For example:"
              (class: #final (TestClass A) [Runnable]
                ## Fields
                (#private foo boolean)
                (#private bar A)
                (#private baz java/lang/Object)
                ## Methods
                (#public [] (new [value A]) []
                         (exec (:= ::foo #1)
                           (:= ::bar value)
                           (:= ::baz "")
                           []))
                (#public (virtual) java/lang/Object
                         "")
                (#public #static (static) java/lang/Object
                         "")
                (Runnable [] (run) void
                          [])
                )

              "The tuple corresponds to parent interfaces."
              "An optional super-class can be specified before the tuple. If not specified, java.lang.Object will be assumed."
              "Fields and methods defined in the class can be used with special syntax."
              "For example:"
              "::resolved, for accessing the 'resolved' field."
              "(:= ::resolved #1) for modifying it."
              "(::new! []) for calling the class's constructor."
              "(::resolve! container [value]) for calling the 'resolve' method."
              )}
  (do macro.monad
    [current-module macro.current-module-name
     #let [fully-qualified-class-name (format (sanitize current-module) "." full-class-name)
           field-parsers (list@map (field->parser fully-qualified-class-name) fields)
           method-parsers (list@map (method->parser (product.right class-decl) fully-qualified-class-name) methods)
           replacer (parser->replacer (list@fold p.either
                                                 (p.fail "")
                                                 (list@compose field-parsers method-parsers)))
           def-code (format "jvm class:"
                            (spaced (list (class-decl$ class-decl)
                                          (super-class-decl$ super)
                                          (with-brackets (spaced (list@map super-class-decl$ interfaces)))
                                          (inheritance-modifier$ im)
                                          (with-brackets (spaced (list@map annotation$ annotations)))
                                          (with-brackets (spaced (list@map field-decl$ fields)))
                                          (with-brackets (spaced (list@map (method-def$ replacer super) methods))))))]]
    (wrap (list (` ((~ (code.text def-code))))))))

(syntax: #export (interface:
                   {#let [imports (class-imports *compiler*)]}
                   {class-decl (class-decl^ imports)}
                   {#let [full-class-name (product.left class-decl)
                          imports (add-import [(short-class-name full-class-name) full-class-name]
                                              (class-imports *compiler*))]}
                   {#let [class-vars (product.right class-decl)]}
                   {supers (p.default (list)
                                      (s.tuple (p.some (super-class-decl^ imports class-vars))))}
                   {annotations (annotations^ imports)}
                   {members (p.some (method-decl^ imports class-vars))})
  {#.doc (doc "Allows defining JVM interfaces."
              (interface: TestInterface
                ([] foo [boolean String] void #throws [Exception])))}
  (let [def-code (format "jvm interface:"
                         (spaced (list (class-decl$ class-decl)
                                       (with-brackets (spaced (list@map super-class-decl$ supers)))
                                       (with-brackets (spaced (list@map annotation$ annotations)))
                                       (spaced (list@map method-decl$ members)))))]
    (wrap (list (` ((~ (code.text def-code))))))
    ))

(syntax: #export (object
                   {#let [imports (class-imports *compiler*)]}
                   {class-vars (s.tuple (p.some (type-param^ imports)))}
                   {super (p.default object-super-class
                                     (super-class-decl^ imports class-vars))}
                   {interfaces (p.default (list)
                                          (s.tuple (p.some (super-class-decl^ imports class-vars))))}
                   {constructor-args (constructor-args^ imports class-vars)}
                   {methods (p.some (overriden-method-def^ imports))})
  {#.doc (doc "Allows defining anonymous classes."
              "The 1st tuple corresponds to class-level type-variables."
              "The 2nd tuple corresponds to parent interfaces."
              "The 3rd tuple corresponds to arguments to the super class constructor."
              "An optional super-class can be specified before the 1st tuple. If not specified, java.lang.Object will be assumed."
              (object [] [Runnable]
                []
                (Runnable [] (run self) void
                          (exec (do-something some-value)
                            [])))
              )}
  (let [def-code (format "jvm anon-class:"
                         (spaced (list (super-class-decl$ super)
                                       (with-brackets (spaced (list@map super-class-decl$ interfaces)))
                                       (with-brackets (spaced (list@map constructor-arg$ constructor-args)))
                                       (with-brackets (spaced (list@map (method-def$ function.identity super) methods))))))]
    (wrap (list (` ((~ (code.text def-code))))))))

(syntax: #export (null)
  {#.doc (doc "Null object reference."
              (null))}
  (wrap (list (` ("jvm object null")))))

(def: #export (null? obj)
  {#.doc (doc "Test for null object reference."
              (= (null? (null))
                 true)
              (= (null? "YOLO")
                 false))}
  (-> (primitive "java.lang.Object") Bit)
  ("jvm object null?" obj))

(syntax: #export (??? expr)
  {#.doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it."
              (= (??? (: java/lang/String (null)))
                 #.None)
              (= (??? "YOLO")
                 (#.Some "YOLO")))}
  (with-gensyms [g!temp]
    (wrap (list (` (let [(~ g!temp) (~ expr)]
                     (if ("jvm object null?" (~ g!temp))
                       #.None
                       (#.Some (~ g!temp)))))))))

(syntax: #export (!!! expr)
  {#.doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType."
              "A #.None would get translated into a (null)."
              (= (null)
                 (!!! (??? (: java/lang/Thread (null)))))
              (= "foo"
                 (!!! (??? "foo"))))}
  (with-gensyms [g!value]
    (wrap (list (` ({(#.Some (~ g!value))
                     (~ g!value)

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

(syntax: #export (try expression)
  {#.doc (doc (case (try (risky-computation input))
                (#.Right success)
                (do-something success)

                (#.Left error)
                (recover-from-failure error)))}
  (with-gensyms [g!_]
    (wrap (list (` ("lux try" ((~! io.label) (.function ((~ g!_) (~ g!_))
                                               (~ expression)))))))))

(syntax: #export (check {#let [imports (class-imports *compiler*)]}
                        {class (generic-type^ imports (list))}
                        {unchecked (p.maybe s.any)})
  {#.doc (doc "Checks whether an object is an instance of a particular class."
              "Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes."
              (case (check String "YOLO")
                (#.Some value-as-string)
                #.None))}
  (with-gensyms [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 (.:coerce (~ class-type)
                                            (~ g!unchecked)))
                          #.None))]
      (case unchecked
        (#.Some unchecked)
        (wrap (list (` (: (~ check-type)
                          (let [(~ g!unchecked) (~ unchecked)]
                            (~ check-code))))))

        #.None
        (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check-type))
                          (function ((~ g!_) (~ g!unchecked))
                            (~ check-code))))))
        ))))

(syntax: #export (synchronized lock body)
  {#.doc (doc "Evaluates body, while holding a lock on a given object."
              (synchronized object-to-be-locked
                (exec (do-something ___)
                  (do-something-else ___)
                  (finish-the-computation ___))))}
  (wrap (list (` ("jvm object synchronized" (~ lock) (~ body))))))

(syntax: #export (do-to obj {methods (p.some partial-call^)})
  {#.doc (doc "Call a variety of methods on an object. Then, return the object."
              (do-to object
                (ClassName::method1 arg0 arg1 arg2)
                (ClassName::method2 arg3 arg4 arg5)))}
  (with-gensyms [g!obj]
    (wrap (list (` (let [(~ g!obj) (~ obj)]
                     (exec (~+ (list@map (complete-call$ g!obj) methods))
                       (~ g!obj))))))))

(def: (class-import$ long-name? [full-name params])
  (-> Bit Class-Declaration Code)
  (let [def-name (if long-name?
                   full-name
                   (short-class-name full-name))
        params' (list@map (|>> product.left code.local-identifier) params)]
    (` (def: (~ (code.identifier ["" def-name]))
         {#..jvm-class (~ (code.text full-name))}
         Type
         (All [(~+ params')]
           (primitive (~ (code.text (sanitize full-name)))
                      [(~+ params')]))))))

(def: (member-type-vars class-tvars member)
  (-> (List Type-Parameter) Import-Member-Declaration (List Type-Parameter))
  (case member
    (#ConstructorDecl [commons _])
    (list@compose class-tvars (get@ #import-member-tvars commons))

    (#MethodDecl [commons _])
    (case (get@ #import-member-kind commons)
      #StaticIMK
      (get@ #import-member-tvars commons)

      _
      (list@compose class-tvars (get@ #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 [(^slots [#import-member-tvars #import-member-args]) commons]
      (do macro.monad
        [arg-inputs (monad.map @
                               (: (-> [Bit GenericType] (Meta [Bit Code]))
                                  (function (_ [maybe? _])
                                    (with-gensyms [arg-name]
                                      (wrap [maybe? arg-name]))))
                               import-member-args)
         #let [arg-classes (: (List Text)
                              (list@map (|>> product.right (simple-class$ (list@compose type-params import-member-tvars)))
                                        import-member-args))
               arg-types (list@map (: (-> [Bit GenericType] Code)
                                      (function (_ [maybe? arg])
                                        (let [arg-type (class->type (get@ #import-member-mode commons) type-params arg)]
                                          (if maybe?
                                            (` (Maybe (~ arg-type)))
                                            arg-type))))
                                   import-member-args)]]
        (wrap [arg-inputs arg-classes arg-types])))

    _
    (:: macro.monad wrap [(list) (list) (list)])))

(def: (decorate-return-maybe member return-term)
  (-> Import-Member-Declaration Code Code)
  (case member
    (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
    (if (get@ #import-member-maybe? commons)
      (` (??? (~ return-term)))
      (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))]
        (` (let [(~ g!temp) (~ return-term)]
             (if (not (null? (:coerce (primitive "java.lang.Object")
                                      (~ g!temp))))
               (~ g!temp)
               (error! "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 (get@ <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
    #.Nil #1
    _     #0))

(def: (type-param->type-arg [name _])
  (-> Type-Parameter Code)
  (code.identifier ["" name]))

(template [<name> <byte> <short> <int> <float>]
  [(def: (<name> mode [class expression])
     (-> Primitive-Mode [Text Code] Code)
     (case mode
       #ManualPrM
       expression
       
       #AutoPrM
       (case class
         "byte"  (` (<byte> (~ expression)))
         "short" (` (<short> (~ expression)))
         "int"   (` (<int> (~ expression)))
         "float" (` (<float> (~ expression)))
         _       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@map (function (_ [maybe? input])
                  (if maybe?
                    (` ((~! !!!) (~ (un-quote input))))
                    (un-quote input))))
      (list.zip2 classes)
      (list@map (auto-convert-input mode))))

(def: (member-def-interop type-params kind class [arg-function-inputs arg-classes arg-types] member method-prefix)
  (-> (List Type-Parameter) Class-Kind Class-Declaration [(List [Bit Code]) (List Text) (List Code)] Import-Member-Declaration Text (Meta (List Code)))
  (let [[full-name class-tvars] class
        full-name (sanitize full-name)
        all-params (|> (member-type-vars class-tvars member)
                       (list.filter free-type-param?)
                       (list@map type-param->type-arg))]
    (case member
      (#EnumDecl enum-members)
      (do macro.monad
        [#let [enum-type (: Code
                            (case class-tvars
                              #.Nil
                              (` (primitive (~ (code.text full-name))))

                              _
                              (let [=class-tvars (|> class-tvars
                                                     (list.filter free-type-param?)
                                                     (list@map type-param->type-arg))]
                                (` (All [(~+ =class-tvars)] (primitive (~ (code.text full-name)) [(~+ =class-tvars)]))))))
               getter-interop (: (-> Text Code)
                                 (function (_ name)
                                   (let [getter-name (code.identifier ["" (format method-prefix member-separator name)])]
                                     (` (def: (~ getter-name)
                                          (~ enum-type)
                                          ((~ (code.text (format "jvm getstatic" ":" full-name ":" name)))))))))]]
        (wrap (list@map getter-interop enum-members)))
      
      (#ConstructorDecl [commons _])
      (do macro.monad
        [#let [def-name (code.identifier ["" (format method-prefix member-separator (get@ #import-member-alias commons))])
               jvm-extension (code.text (format "jvm new" ":" full-name ":" (text.join-with "," arg-classes)))
               jvm-interop (|> (` ((~ jvm-extension)
                                   (~+ (jvm-extension-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs))))
                               (decorate-return-maybe member)
                               (decorate-return-try member)
                               (decorate-return-io member))]]
        (wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list@map product.right arg-function-inputs)))
                        ((~' wrap) (.list (.` (~ jvm-interop)))))))))

      (#MethodDecl [commons method])
      (with-gensyms [g!obj]
        (do @
          [#let [def-name (code.identifier ["" (format method-prefix member-separator (get@ #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
                                          ["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.join-with "," arg-classes)))
                 jvm-interop (|> [(simple-class$ (list) (get@ #import-method-return method))
                                  (` ((~ jvm-extension) (~+ (list@map un-quote object-ast))
                                      (~+ (jvm-extension-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs))))]
                                 (auto-convert-output (get@ #import-member-mode commons))
                                 (decorate-return-maybe member)
                                 (decorate-return-try member)
                                 (decorate-return-io member))]]
          (wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list@map product.right arg-function-inputs)) (~+ object-ast))
                          ((~' wrap) (.list (.` (~ jvm-interop))))))))))

      (#FieldAccessDecl fad)
      (do macro.monad
        [#let [(^open ".") 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 (: (List Code)
                            (|> class-tvars
                                (list.filter free-type-param?)
                                (list@map type-param->type-arg)))
               getter-name (code.identifier ["" (format method-prefix member-separator import-field-name)])
               setter-name (code.identifier ["" (format method-prefix member-separator import-field-name "!")])]
         getter-interop (with-gensyms [g!obj]
                          (let [getter-call (if import-field-static?
                                              (` ((~ getter-name)))
                                              (` ((~ getter-name) (~ g!obj))))
                                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)]
                            (wrap (` ((~! syntax:) (~ getter-call)
                                      ((~' wrap) (.list (.` (~ getter-body)))))))))
         setter-interop (: (Meta (List Code))
                           (if import-field-setter?
                             (with-gensyms [g!obj g!value]
                               (let [setter-call (if import-field-static?
                                                   (` ((~ setter-name) (~ g!value)))
                                                   (` ((~ setter-name) (~ g!value) (~ g!obj))))
                                     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+ (: (List Code)
                                               (if import-field-static?
                                                 (list)
                                                 (list (un-quote g!obj))))]
                                 (wrap (list (` ((~! syntax:) (~ setter-call)
                                                 ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter-command)) (~+ g!obj+) (~ setter-value))))))))))))
                             (wrap (list))))]
        (wrap (list& getter-interop setter-interop)))
      )))

(def: (member-import$ type-params long-name? kind class member)
  (-> (List Type-Parameter) Bit Class-Kind Class-Declaration Import-Member-Declaration (Meta (List Code)))
  (let [[full-name _] class
        method-prefix (if long-name?
                        full-name
                        (short-class-name full-name))]
    (do macro.monad
      [=args (member-def-arg-bindings type-params class member)]
      (member-def-interop type-params kind class =args member method-prefix))))

(def: (interface? class)
  (All [a] (-> (primitive "java.lang.Class" [a]) Bit))
  ("jvm invokevirtual:java.lang.Class:isInterface:" class))

(def: (load-class class-name)
  (-> Text (Error (primitive "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 (sanitize class-name)]
    (case (load-class class-name)
      (#.Right class)
      (:: macro.monad wrap (if (interface? class)
                             #Interface
                             #Class))

      (#.Left _)
      (macro.fail (format "Unknown class: " class-name)))))

(syntax: #export (import:
                   {#let [imports (class-imports *compiler*)]}
                   {long-name? (p.parses? (s.this! (' #long)))}
                   {class-decl (class-decl^ imports)}
                   {#let [full-class-name (product.left class-decl)
                          imports (add-import [(short-class-name full-class-name) full-class-name]
                                              (class-imports *compiler*))]}
                   {members (p.some (import-member-decl^ imports (product.right class-decl)))})
  {#.doc (doc "Allows importing JVM classes, and using them as types."
              "Their methods, fields and enum options can also be imported."
              "Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes."
              (import: java/lang/Object
                (new [])
                (equals [Object] boolean)
                (wait [int] #io #try void))
              
              "Special options can also be given for the return values."
              "#? means that the values will be returned inside a Maybe type. That way, null becomes #.None."
              "#try means that the computation might throw an exception, and the return value will be wrapped by the Error type."
              "#io means the computation has side effects, and will be wrapped by the IO type."
              "These options must show up in the following order [#io #try #?] (although, each option can be used independently)."
              (import: java/lang/String
                (new [(Array byte)])
                (#static valueOf [char] String)
                (#static valueOf #as int-valueOf [int] String))

              (import: #long (java/util/List e)
                (size [] int)
                (get [int] e))

              (import: (java/util/ArrayList a)
                ([T] toArray [(Array T)] (Array T)))
              
              "#long makes it so the class-type that is generated is of the fully-qualified name."
              "In this case, it avoids a clash between the java.util.List type, and Lux's own List type."
              "All enum options to be imported must be specified."
              (import: java/lang/Character$UnicodeScript
                (#enum ARABIC CYRILLIC LATIN))

              "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters."
              "Lux types, such as Maybe cannot be named (otherwise, they'd be confused for Java classes)."
              (import: #long (lux/concurrency/promise/JvmPromise A)
                (resolve [A] boolean)
                (poll [] A)
                (wasResolved [] boolean)
                (waitOn [lux/Function] void)
                (#static [A] make [A] (JvmPromise A)))
              
              "Also, the names of the imported members will look like Class::member"
              (Object::new [])
              (Object::equals [other-object] my-object)
              (java/util/List::size [] my-list)
              Character$UnicodeScript::LATIN
              )}
  (do macro.monad
    [kind (class-kind class-decl)
     =members (monad.map @ (member-import$ (product.right class-decl) long-name? kind class-decl) members)]
    (wrap (list& (class-import$ long-name? class-decl) (list@join =members)))))

(syntax: #export (array {#let [imports (class-imports *compiler*)]}
                        {type (generic-type^ imports (list))}
                        size)
  {#.doc (doc "Create an array of the given type, with the given size."
              (array Object 10))}
  (case type
    (^template [<type> <array-op>]
      (^ (#GenericClass <type> (list)))
      (wrap (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"])

    _
    (wrap (list (` ("jvm anewarray" (~ (code.text (generic-type$ type))) (~ size)))))))

(syntax: #export (array-length array)
  {#.doc (doc "Gives the length of an array."
              (array-length my-array))}
  (wrap (list (` ("jvm arraylength" (~ array))))))

(def: (type->class-name type)
  (-> Type (Meta Text))
  (if (type@= Any type)
    (:: macro.monad wrap "java.lang.Object")
    (case type
      (#.Primitive name params)
      (:: macro.monad wrap name)

      (#.Apply A F)
      (case (type.apply (list A) F)
        #.None
        (macro.fail (format "Cannot apply type: " (type.to-text F) " to " (type.to-text A)))

        (#.Some type')
        (type->class-name type'))
      
      (#.Named _ type')
      (type->class-name type')

      _
      (macro.fail (format "Cannot convert to JvmType: " (type.to-text type))))))

(syntax: #export (array-read idx array)
  {#.doc (doc "Loads an element from an array."
              (array-read 10 my-array))}
  (case array
    [_ (#.Identifier array-name)]
    (do macro.monad
      [array-type (macro.find-type array-name)
       array-jvm-type (type->class-name array-type)]
      (case array-jvm-type
        (^template [<type> <array-op>]
          <type>
          (wrap (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"])

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

    _
    (with-gensyms [g!array]
      (wrap (list (` (let [(~ g!array) (~ array)]
                       (..array-read (~ idx) (~ g!array)))))))))

(syntax: #export (array-write idx value array)
  {#.doc (doc "Stores an element into an array."
              (array-write 10 my-object my-array))}
  (case array
    [_ (#.Identifier array-name)]
    (do macro.monad
      [array-type (macro.find-type array-name)
       array-jvm-type (type->class-name array-type)]
      (case array-jvm-type
        (^template [<type> <array-op>]
          <type>
          (wrap (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"])

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

    _
    (with-gensyms [g!array]
      (wrap (list (` (let [(~ g!array) (~ array)]
                       (..array-write (~ idx) (~ value) (~ g!array)))))))))

(syntax: #export (class-for {#let [imports (class-imports *compiler*)]}
                            {type (generic-type^ imports (list))})
  {#.doc (doc "Loads the class as a java.lang.Class object."
              (class-for java/lang/String))}
  (wrap (list (` ("jvm object class" (~ (code.text (simple-class$ (list) type))))))))

(def: get-compiler
  (Meta Lux)
  (function (_ compiler)
    (#.Right [compiler compiler])))

(def: #export (resolve class)
  {#.doc (doc "Given a potentially unqualified class name, qualifies it if necessary."
              (resolve "String")
              =>
              "java.lang.String")}
  (-> Text (Meta Text))
  (do macro.monad
    [*compiler* get-compiler]
    (wrap (qualify (class-imports *compiler*) class))))

(syntax: #export (type {#let [imports (class-imports *compiler*)]}
                       {type (generic-type^ imports (list))})
  (wrap (list (class->type #ManualPrM (list) type))))