path: root/stdlib/source/lux/tool/compiler/phase/extension/directive/jvm.lux

(.module:
  [lux (#- Type Definition)
   ["." host]
   [abstract
    ["." monad (#+ do)]]
   [control
    [pipe (#+ case>)]
    ["<>" parser ("#@." monad)
     ["<c>" code (#+ Parser)]
     ["<t>" text]]]
   [data
    ["." product]
    [number
     ["." i32]]
    [text
     ["%" format (#+ format)]]
    [collection
     ["." list ("#@." functor fold)]
     ["." dictionary]
     ["." row]]]
   [type
    ["." check (#+ Check)]]
   [macro
    ["." template]]
   [target
    [jvm
     ["_" bytecode (#+ Bytecode)]
     ["." modifier (#+ Modifier) ("#@." monoid)]
     ["." attribute]
     ["." field]
     ["." version]
     ["." class]
     ["." constant
      ["." pool (#+ Resource)]]
     [encoding
      ["." name]]
     ["." type (#+ Type Constraint Argument Typed)
      [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
      [".T" lux (#+ Mapping)]
      ["." signature]
      ["." descriptor (#+ Descriptor)]
      ["." parser]]]]
   [tool
    [compiler
     ["." analysis]
     ["." synthesis]
     ["." directive (#+ Handler Bundle)]
     ["." phase
      [analysis
       [".A" type]]
      ["." generation
       [jvm
        [runtime (#+ Anchor Definition)]]]
      ["." extension
       ["." bundle]
       [analysis
        ["." jvm]]
       [directive
        ["/" lux]]]]]]])

(type: Operation
  (directive.Operation Anchor (Bytecode Any) Definition))

(def: signature (|>> type.signature signature.signature))

(type: Declaration
  [Text (List (Type Var))])

(def: declaration
  (Parser Declaration)
  (<c>.form (<>.and <c>.text (<>.some jvm.var))))

(def: visibility
  (Parser (Modifier field.Field))
  (`` ($_ <>.either
          (~~ (template [<label> <modifier>]
                [(<>.after (<c>.text! <label>) (<>@wrap <modifier>))]

                ["public" field.public]
                ["private" field.private]
                ["protected" field.protected]
                ["default" modifier.empty])))))

(def: inheritance
  (Parser (Modifier class.Class))
  (`` ($_ <>.either
          (~~ (template [<label> <modifier>]
                [(<>.after (<c>.text! <label>) (<>@wrap <modifier>))]

                ["final" class.final]
                ["abstract" class.abstract]
                ["default" modifier.empty])))))

(def: state
  (Parser (Modifier field.Field))
  (`` ($_ <>.either
          (~~ (template [<label> <modifier>]
                [(<>.after (<c>.text! <label>) (<>@wrap <modifier>))]

                ["volatile" field.volatile]
                ["final" field.final]
                ["default" modifier.empty])))))

(type: Annotation Any)

(def: annotation
  (Parser Annotation)
  <c>.any)

(def: field-type
  (Parser (Type Value))
  (<t>.embed parser.value <c>.text))

(type: Constant
  [Text (List Annotation) (Type Value) Code])

(def: constant
  (Parser Constant)
  (<| <c>.form
      (<>.after (<c>.text! "constant"))
      ($_ <>.and
          <c>.text
          (<c>.tuple (<>.some ..annotation))
          ..field-type
          <c>.any
          )))

(type: Variable
  [Text (Modifier field.Field) (Modifier field.Field) (List Annotation) (Type Value)])

(def: variable
  (Parser Variable)
  (<| <c>.form
      (<>.after (<c>.text! "variable"))
      ($_ <>.and
          <c>.text
          ..visibility
          ..state
          (<c>.tuple (<>.some ..annotation))
          ..field-type
          )))

(type: Field
  (#Constant Constant)
  (#Variable Variable))

(def: field
  (Parser Field)
  ($_ <>.or
      ..constant
      ..variable
      ))

(type: Method-Definition
  (#Constructor (jvm.Constructor Code))
  (#Virtual-Method (jvm.Virtual-Method Code))
  (#Static-Method (jvm.Static-Method Code))
  (#Overriden-Method (jvm.Overriden-Method Code)))

(def: method
  (Parser Method-Definition)
  ($_ <>.or
      jvm.constructor-definition
      jvm.virtual-method-definition
      jvm.static-method-definition
      jvm.overriden-method-definition
      ))

(def: (constraint name)
  (-> Text Constraint)
  {#type.name name
   #type.super-class (type.class "java.lang.Object" (list))
   #type.super-interfaces (list)})

(def: constant::modifier
  (Modifier field.Field)
  ($_ modifier@compose
      field.public
      field.static
      field.final))

(def: (field-definition field)
  (-> Field (Resource field.Field))
  (case field
    ## TODO: Handle annotations.
    (#Constant [name annotations type value])
    (case value
      (^template [<tag> <type> <constant>]
        [_ (<tag> value)]
        (do pool.monad
          [constant (`` (|> value (~~ (template.splice <constant>))))
           attribute (attribute.constant constant)]
          (field.field ..constant::modifier name <type> (row.row attribute))))
      ([#.Bit type.boolean [(case> #0 +0 #1 +1) .i64 i32.i32 constant.integer pool.integer]]
       [#.Int type.byte [.i64 i32.i32 constant.integer pool.integer]]
       [#.Int type.short [.i64 i32.i32 constant.integer pool.integer]]
       [#.Int type.int [.i64 i32.i32 constant.integer pool.integer]]
       [#.Int type.long [constant.long pool.long]]
       [#.Frac type.float [host.double-to-float constant.float pool.float]]
       [#.Frac type.double [constant.double pool.double]]
       [#.Nat type.char [.i64 i32.i32 constant.integer pool.integer]]
       [#.Text (type.class "java.lang.String" (list)) [pool.string]]
       )

      ## TODO: Tighten this pattern-matching so this catch-all clause isn't necessary.
      _
      (undefined))

    ## TODO: Handle annotations.
    (#Variable [name visibility state annotations type])
    (field.field (modifier@compose visibility state)
                 name type (row.row))))

(def: (method-definition [mapping selfT] [analyse synthesize generate])
  (-> [Mapping .Type]
      [analysis.Phase
       synthesis.Phase
       (generation.Phase Anchor (Bytecode Any) Definition)]
      (-> Method-Definition (Operation synthesis.Synthesis)))
  (function (_ methodC)
    (do phase.monad
      [methodA (: (Operation analysis.Analysis)
                  (directive.lift-analysis
                   (case methodC
                     (#Constructor method)
                     (jvm.analyse-constructor-method analyse selfT mapping method)

                     (#Virtual-Method method)
                     (jvm.analyse-virtual-method analyse selfT mapping method)
                     
                     (#Static-Method method)
                     (jvm.analyse-static-method analyse mapping method)
                     
                     (#Overriden-Method method)
                     (jvm.analyse-overriden-method analyse selfT mapping method))))]
      (directive.lift-synthesis
       (synthesize methodA)))))

(def: jvm::class
  (Handler Anchor (Bytecode Any) Definition)
  (/.custom
   [($_ <>.and
        ..declaration
        jvm.class
        (<c>.tuple (<>.some jvm.class))
        ..inheritance
        (<c>.tuple (<>.some ..annotation))
        (<c>.tuple (<>.some ..field))
        (<c>.tuple (<>.some ..method)))
    (function (_ extension phase
                 [[name parameters]
                  super-class
                  super-interfaces
                  inheritance
                  ## TODO: Handle annotations.
                  annotations
                  fields
                  methods])
      (do phase.monad
        [parameters (directive.lift-analysis
                     (typeA.with-env
                       (jvm.parameter-types parameters)))
         #let [mapping (list@fold (function (_ [parameterJ parameterT] mapping)
                                    (dictionary.put (parser.name parameterJ) parameterT mapping))
                                  luxT.fresh
                                  parameters)]
         super-classT (directive.lift-analysis
                       (typeA.with-env
                         (luxT.check (luxT.class mapping) (..signature super-class))))
         super-interfaceT+ (directive.lift-analysis
                            (typeA.with-env
                              (monad.map check.monad
                                         (|>> ..signature (luxT.check (luxT.class mapping)))
                                         super-interfaces)))
         #let [selfT (jvm.inheritance-relationship-type (#.Primitive name (list@map product.right parameters))
                                                        super-classT
                                                        super-interfaceT+)]
         state (extension.lift phase.get-state)
         #let [analyse (get@ [#directive.analysis #directive.phase] state)
               synthesize (get@ [#directive.synthesis #directive.phase] state)
               generate (get@ [#directive.generation #directive.phase] state)]
         methods (monad.map @ (..method-definition [mapping selfT] [analyse synthesize generate])
                            methods)
         ## _ (directive.lift-generation
         ##    (generation.save! true ["" name]
         ##                      [name
         ##                       (class.class version.v6_0
         ##                                    (modifier@compose class.public inheritance)
         ##                                    (name.internal name) (list@map (|>> product.left parser.name ..constraint) parameters)
         ##                                    super-class super-interfaces
         ##                                    (list@map ..field-definition fields)
         ##                                    (list) ## TODO: Add methods
         ##                                    (row.row))]))
         #let [_ (log! (format "Class " name))]]
        (wrap directive.no-requirements)))]))

(def: #export bundle
  (Bundle Anchor (Bytecode Any) Definition)
  (<| (bundle.prefix "jvm")
      (|> bundle.empty
          ## TODO: Finish handling methods and un-comment.
          ## (dictionary.put "class" jvm::class)
          )))