WIP: Class definition.

2 files changed, 264 insertions, 1 deletions

diff --git a/new-luxc/source/luxc/lang/statement/jvm.lux b/new-luxc/source/luxc/lang/statement/jvm.lux
new file mode 100644
index 000000000..a21cc76c8
--- /dev/null
+++ b/new-luxc/source/luxc/lang/statement/jvm.lux
@@ -0,0 +1,262 @@
+(.module:
+  [lux (#- Definition)
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["<>" parser
+     ["<c>" code (#+ Parser)]]]
+   [data
+    ["." product]
+    [text
+     format]
+    [collection
+     ["." list ("#@." functor fold)]
+     ["." dictionary]]]
+   [type
+    ["." check (#+ Check)]]
+   [target
+    [jvm
+     ["." type (#+ Var Parameter Class Argument Typed Return)
+      [".T" lux]]]]
+   [tool
+    [compiler
+     ["." statement (#+ Handler Bundle)]
+     ["." phase
+      ["." generation]
+      [analysis
+       [".A" type]]
+      ["." extension
+       ["." bundle]
+       [analysis
+        ["." jvm]]
+       [statement
+        ["/" lux]]]]]]]
+  [luxc
+   [lang
+    [host
+     ["$" jvm (#+ Anchor Inst Definition Operation Phase)
+      ["_" inst]
+      ["_." def]]]]])
+
+(type: Declaration
+  [Text (List Text)])
+
+(def: declaration
+  (Parser Declaration)
+  (<c>.form (<>.and <c>.text (<>.some <c>.text))))
+
+(type: Inheritance
+  #FinalI
+  #AbstractI
+  #DefaultI)
+
+(def: inheritance
+  (Parser Inheritance)
+  ($_ <>.or
+      (<c>.text! "final")
+      (<c>.text! "abstract")
+      (<c>.text! "default")))
+
+(type: State
+  #VolatileS
+  #FinalS
+  #DefaultS)
+
+(def: state
+  (Parser State)
+  ($_ <>.or
+      (<c>.text! "volatile")
+      (<c>.text! "final")
+      (<c>.text! "default")))
+
+(type: Annotation Any)
+
+(def: annotation
+  (Parser Annotation)
+  <c>.any)
+
+(type: Constant
+  [Text (List Annotation) type.Type Code])
+
+(def: constant
+  (Parser Constant)
+  (<| <c>.form
+      (<>.after (<c>.text! "constant"))
+      ($_ <>.and
+          <c>.text
+          (<c>.tuple (<>.some ..annotation))
+          jvm.type
+          <c>.any
+          )))
+
+(type: Variable
+  [Text jvm.Visibility State (List Annotation) type.Type])
+
+(def: variable
+  (Parser Variable)
+  (<| <c>.form
+      (<>.after (<c>.text! "variable"))
+      ($_ <>.and
+          <c>.text
+          jvm.visibility
+          ..state
+          (<c>.tuple (<>.some ..annotation))
+          jvm.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: (parameter name)
+  (-> Text Parameter)
+  [name [type.object-class (list)] (list)])
+
+(def: string-descriptor (type.descriptor (type.class "java.lang.String" (list))))
+
+(def: parameter-types
+  (-> (List Var) (Check (List [Var Type])))
+  (monad.map check.monad
+             (function (_ parameterJ)
+               (do check.monad
+                 [[_ parameterT] check.var]
+                 (wrap [parameterJ parameterT])))))
+
+(def: jvm::class
+  (Handler Anchor Inst 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 (statement.lift-analysis
+                     (typeA.with-env
+                       (parameter-types parameters)))
+         #let [mapping (list@fold (function (_ [parameterJ parameterT] mapping)
+                                    (dictionary.put parameterJ parameterT mapping))
+                                  luxT.fresh
+                                  parameters)
+               field-definitions (|> fields
+                                     (list@map (function (_ field)
+                                                 (case field
+                                                   ## TODO: Handle annotations.
+                                                   (#Constant [name annotations type value])
+                                                   (case [(type.descriptor type) value]
+                                                     (^template [<descriptor> <tag> <field>]
+                                                       (^ [(static <descriptor>) [_ (<tag> value)]])
+                                                       (<field> #$.Public $.finalF name value))
+                                                     ([type.boolean-descriptor #.Bit _def.boolean-field]
+                                                      [type.byte-descriptor #.Int _def.byte-field]
+                                                      [type.short-descriptor #.Int _def.short-field]
+                                                      [type.int-descriptor #.Int _def.int-field]
+                                                      [type.long-descriptor #.Int _def.long-field]
+                                                      [type.float-descriptor #.Frac _def.float-field]
+                                                      [type.double-descriptor #.Frac _def.double-field]
+                                                      [type.char-descriptor #.Nat _def.char-field]
+                                                      [string-descriptor #.Text _def.string-field])
+                                                     
+                                                     ## TODO: Handle constants better.
+                                                     _
+                                                     (undefined))
+
+                                                   ## TODO: Handle annotations.
+                                                   (#Variable [name visibility state annotations type])
+                                                   (_def.field visibility
+                                                               (case state
+                                                                 ## TODO: Handle transient & static.
+                                                                 #VolatileS $.volatileF
+                                                                 #FinalS $.finalF
+                                                                 #DefaultS $.noneF)
+                                                               name
+                                                               type))))
+                                     _def.fuse)]
+         super-classT (statement.lift-analysis
+                       (typeA.with-env
+                         (luxT.class mapping super-class)))
+         super-interfaceT+ (statement.lift-analysis
+                            (typeA.with-env
+                              (monad.map check.monad
+                                         (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@ [#statement.analysis #statement.phase] state)
+               synthesize (get@ [#statement.synthesis #statement.phase] state)
+               generate (get@ [#statement.generation #statement.phase] state)]
+         methods (monad.map @ (function (_ methodC)
+                                (do @
+                                  [methodA (statement.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)))]
+                                  (statement.lift-synthesis
+                                   (synthesize methodA))))
+                            methods)
+         _ (statement.lift-generation
+            (generation.save! true ["" name]
+                              [name
+                               (_def.class #$.V1_6 #$.Public
+                                           (case inheritance
+                                             #FinalI $.finalC
+                                             ## TODO: Handle abstract classes.
+                                             #AbstractI (undefined)
+                                             #DefaultI $.noneC)
+                                           name (list@map (|>> product.left ..parameter) parameters)
+                                           super-class super-interfaces
+                                           (|>> field-definitions))]))
+         #let [_ (log! (format "Class " name))]]
+        (wrap statement.no-requirements)))]))
+
+(def: #export bundle
+  (Bundle Anchor Inst Definition)
+  (<| (bundle.prefix "jvm")
+      (|> bundle.empty
+          (dictionary.put "class" jvm::class)
+          )))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
index 4239a89aa..ce5d797b4 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -886,7 +886,8 @@
 (def: overriden-method-definition
   (Parser [Environment (/.Overriden-Method Synthesis)])
   (<s>.tuple (do <>.monad
-               [ownerT ..class
+               [_ (<s>.text! /.overriden-tag)
+                ownerT ..class
                 name <s>.text
                 strict-fp? <s>.bit
                 annotations (<s>.tuple (<>.some ..annotation))