1 files changed, 303 insertions, 0 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/directive/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/directive/jvm.lux
new file mode 100644
index 000000000..4db15e8e6
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/extension/directive/jvm.lux
@@ -0,0 +1,303 @@
+(.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)
+          )))