diff options
Diffstat (limited to '')
| -rw-r--r-- | lux-jvm/source/luxc/lang/directive/jvm.lux | 844 |
1 files changed, 826 insertions, 18 deletions
diff --git a/lux-jvm/source/luxc/lang/directive/jvm.lux b/lux-jvm/source/luxc/lang/directive/jvm.lux index 3ebcfe641..841f31b92 100644 --- a/lux-jvm/source/luxc/lang/directive/jvm.lux +++ b/lux-jvm/source/luxc/lang/directive/jvm.lux @@ -1,22 +1,23 @@ (.module: [library - [lux (#- Type) - [ffi (#+ import:)] - [type (#+ :share)] + [lux (#- Type static) + ["." ffi (#+ Inheritance Privacy State import:)] [abstract ["." monad (#+ do)]] [control + [pipe (#+ case>)] ["." try (#+ Try)] ["<>" parser ["<.>" code (#+ Parser)] ["<.>" text]]] [data [identity (#+ Identity)] + [binary (#+ Binary)] ["." product] [text ["%" format (#+ format)]] [collection - ["." list ("#\." fold functor)] + ["." list ("#\." fold functor monoid)] ["." dictionary (#+ Dictionary)] ["." row (#+ Row) ("#\." functor fold)]]] [math @@ -26,9 +27,10 @@ ["/" jvm [encoding ["." name (#+ External)]] - ["#." type (#+ Type) - [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)] + ["#." type (#+ Type Constraint) + [category (#+ Void Value Return Primitive Object Class Array Var Parameter)] ["." parser] + [".T" lux] ["#/." signature] ["#/." descriptor]]]] [tool @@ -36,12 +38,18 @@ ["." phase] [language [lux - [synthesis (#+ Synthesis)] + ["." analysis (#+ Analysis)] + ["." synthesis (#+ Synthesis)] ["." generation] ["." directive (#+ Requirements)] [phase + [analysis + [".A" scope] + [".A" type]] ["." extension ["." bundle] + [analysis + ["//A" jvm]] [directive ["./" lux]]]]]] [meta @@ -50,7 +58,11 @@ [host ["." jvm (#+ Inst) ["_" inst] - ["." def]]]]) + ["." def]]] + [translation + [jvm + [extension + ["//G" host]]]]]) (import: org/objectweb/asm/Label ["#::." @@ -580,6 +592,9 @@ (#try.Failure error) (phase.throw extension.invalid_syntax [extension_name %.code input])))) +(type: Declaration + [External (List (Type Var))]) + (template [<name> <type> <parser>] [(def: <name> (Parser <type>) @@ -587,19 +602,23 @@ [raw <code>.text] (<>.lift (<text>.run <parser> raw))))] - [class_declaration [External (List (Type Var))] parser.declaration'] + [class_declaration Declaration parser.declaration'] [class (Type Class) parser.class] [type_variable (Type Var) parser.var] [value (Type Value) parser.value] + [return_type (Type Return) parser.return] ) +(type: Annotation + Code) + (def: annotation - (Parser Code) + (Parser Annotation) <code>.any) (type: Method_Declaration {#name Text - #annotations (List Code) + #annotations (List Annotation) #type_variables (List (Type Var)) #exceptions (List (Type Class)) #arguments (List (Type Value)) @@ -620,6 +639,799 @@ (def: java/lang/Object (/type.class "java.lang.Object" (list))) +(def: inheritance + (Parser Inheritance) + ($_ <>.or + (<code>.text! "final") + (<code>.text! "abstract") + (<code>.text! "default") + )) + +(def: privacy + (Parser Privacy) + ($_ <>.or + (<code>.text! "public") + (<code>.text! "private") + (<code>.text! "protected") + (<code>.text! "default") + )) + +(def: state + (Parser State) + ($_ <>.or + (<code>.text! "volatile") + (<code>.text! "final") + (<code>.text! "default") + )) + +(type: Field + [Text Privacy State (List Annotation) (Type Value)]) + +(def: field + (Parser Field) + (<code>.form + (do <>.monad + [_ (<code>.text! "variable") + name <code>.text + privacy ..privacy + state ..state + _ (<code>.tuple (<>.some ..annotation)) + type ..value] + (wrap [name privacy state (list) type])))) + +(type: Argument + [Text (Type Value)]) + +(def: argument + (Parser Argument) + (<code>.tuple + (<>.and <code>.text + ..value))) + +(type: (Constructor a) + [Privacy Bit (List Annotation) (List (Type Var)) (List (Type Class)) + Text (List Argument) (List [(Type Value) a]) + a]) + +(type: (Override a) + [Declaration Text Bit (List Annotation) (List (Type Var)) + Text (List Argument) (Type Return) (List (Type Class)) + a]) + +(type: (Virtual a) + [Text Privacy Bit Bit (List Annotation) (List (Type Var)) + Text (List Argument) (Type Return) (List (Type Class)) + a]) + +(type: (Static a) + [Text Privacy Bit (List Annotation) (List (Type Var)) + (List Argument) (Type Return) (List (Type Class)) + a]) + +(type: Abstract + [Text Privacy (List Annotation) (List (Type Var)) + (List Argument) (Type Return) (List (Type Class))]) + +(type: (Method a) + (#Constructor (Constructor a)) + (#Override (Override a)) + (#Virtual (Virtual a)) + (#Static (Static a)) + (#Abstract Abstract)) + +(def: constructor + (Parser (Constructor Code)) + (let [constructor_argument (: (Parser [(Type Value) Code]) + (<code>.tuple + (<>.and ..value + <code>.any)))] + (<| <code>.form + (<>.after (<code>.text! "init")) + ($_ <>.and + ..privacy + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..type_variable)) + (<code>.tuple (<>.some ..class)) + <code>.text + (<code>.tuple (<>.some ..argument)) + (<code>.tuple (<>.some constructor_argument)) + <code>.any + )))) + +(def: override + (Parser (Override Code)) + (<| <code>.form + (<>.after (<code>.text! "override")) + ($_ <>.and + ..class_declaration + <code>.text + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..type_variable)) + <code>.text + (<code>.tuple (<>.some ..argument)) + ..return_type + (<code>.tuple (<>.some ..class)) + <code>.any + ))) + +(def: virtual + (Parser (Virtual Code)) + (<| <code>.form + (<>.after (<code>.text! "virtual")) + ($_ <>.and + <code>.text + ..privacy + <code>.bit + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..type_variable)) + <code>.text + (<code>.tuple (<>.some ..argument)) + ..return_type + (<code>.tuple (<>.some ..class)) + <code>.any + ))) + +(def: static + (Parser (Static Code)) + (<| <code>.form + (<>.after (<code>.text! "static")) + ($_ <>.and + <code>.text + ..privacy + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..type_variable)) + (<code>.tuple (<>.some ..argument)) + ..return_type + (<code>.tuple (<>.some ..class)) + <code>.any + ))) + +(def: abstract + (Parser Abstract) + (<| <code>.form + (<>.after (<code>.text! "abstract")) + ($_ <>.and + <code>.text + ..privacy + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..type_variable)) + (<code>.tuple (<>.some ..argument)) + ..return_type + (<code>.tuple (<>.some ..class)) + ))) + +(def: method + (Parser (Method Code)) + ($_ <>.or + ..constructor + ..override + ..virtual + ..static + ..abstract + )) + +(def: (constraint tv) + (-> (Type Var) Constraint) + {#/type.name (parser.name tv) + #/type.super_class java/lang/Object + #/type.super_interfaces (list)}) + +(def: visibility + (-> ffi.Privacy jvm.Visibility) + (|>> (case> #ffi.PublicP #jvm.Public + #ffi.PrivateP #jvm.Private + #ffi.ProtectedP #jvm.Protected + #ffi.DefaultP #jvm.Default))) + +(def: field_config + (-> ffi.State jvm.Field_Config) + (|>> (case> #ffi.VolatileS jvm.volatileF + #ffi.FinalS jvm.finalF + #ffi.DefaultS jvm.noneF))) + +(def: (field_header [name privacy state annotations type]) + (-> Field jvm.Def) + (def.field (..visibility privacy) (..field_config state) name type)) + +(def: (header_value valueT) + (-> (Type Value) Inst) + (case (/type.primitive? valueT) + (#.Left classT) + _.NULL + + (#.Right primitiveT) + (cond (or (\ /type.equivalence = /type.boolean primitiveT) + (\ /type.equivalence = /type.byte primitiveT) + (\ /type.equivalence = /type.short primitiveT) + (\ /type.equivalence = /type.int primitiveT) + (\ /type.equivalence = /type.char primitiveT)) + _.ICONST_0 + + (\ /type.equivalence = /type.long primitiveT) + _.LCONST_0 + + (\ /type.equivalence = /type.float primitiveT) + _.FCONST_0 + + ## (\ /type.equivalence = /type.double primitiveT) + _.DCONST_0))) + +(def: (header_return returnT) + (-> (Type Return) Inst) + (case (/type.void? returnT) + (#.Right returnT) + _.RETURN + + (#.Left valueT) + (case (/type.primitive? valueT) + (#.Left classT) + (|>> (header_value classT) + _.ARETURN) + + (#.Right primitiveT) + (cond (or (\ /type.equivalence = /type.boolean primitiveT) + (\ /type.equivalence = /type.byte primitiveT) + (\ /type.equivalence = /type.short primitiveT) + (\ /type.equivalence = /type.int primitiveT) + (\ /type.equivalence = /type.char primitiveT)) + (|>> (header_value primitiveT) + _.IRETURN) + + (\ /type.equivalence = /type.long primitiveT) + (|>> (header_value primitiveT) + _.LRETURN) + + (\ /type.equivalence = /type.float primitiveT) + (|>> (header_value primitiveT) + _.FRETURN) + + ## (\ /type.equivalence = /type.double primitiveT) + (|>> (header_value primitiveT) + _.DRETURN))))) + +(def: constructor_name + "<init>") + +(def: (abstract_method_generation method) + (-> Abstract jvm.Def) + (let [[name privacy annotations variables + arguments return exceptions] method] + (def.abstract_method (..visibility privacy) + jvm.noneM + name + (/type.method [variables (list\map product.right arguments) return exceptions])))) + +(def: (method_header super_class method) + (-> (Type Class) (Method Code) jvm.Def) + (case method + (#Constructor [privacy strict_floating_point? annotations variables exceptions + self arguments constructor_arguments + body]) + (let [[super_name super_vars] (parser.read_class super_class) + init_constructor_arguments (|> constructor_arguments + (list\map (|>> product.left ..header_value)) + _.fuse) + super_constructorT (/type.method [(list) + (list\map product.left constructor_arguments) + /type.void + (list)])] + (def.method (..visibility privacy) + (if strict_floating_point? + jvm.strictM + jvm.noneM) + ..constructor_name + (/type.method [variables (list\map product.right arguments) /type.void exceptions]) + (|>> (_.ALOAD 0) + init_constructor_arguments + (_.INVOKESPECIAL super_class ..constructor_name super_constructorT) + _.RETURN))) + + (#Override [[parent_name parent_variables] name strict_floating_point? annotations variables + self arguments return exceptions + body]) + (def.method #jvm.Public + (if strict_floating_point? + jvm.strictM + jvm.noneM) + name + (/type.method [variables (list\map product.right arguments) return exceptions]) + (..header_return return)) + + (#Virtual [name privacy final? strict_floating_point? annotations variables + self arguments return exceptions + body]) + (def.method (..visibility privacy) + (|> jvm.noneM + (jvm.++M (if strict_floating_point? + jvm.strictM + jvm.noneM)) + (jvm.++M (if final? + jvm.finalM + jvm.noneM))) + name + (/type.method [variables (list\map product.right arguments) return exceptions]) + (..header_return return)) + + (#Static [name privacy strict_floating_point? annotations variables + arguments return exceptions + body]) + (def.method (..visibility privacy) + (|> jvm.staticM + (jvm.++M (if strict_floating_point? + jvm.strictM + jvm.noneM))) + name + (/type.method [variables (list\map product.right arguments) return exceptions]) + (..header_return return)) + + (#Abstract method) + (..abstract_method_generation method) + )) + +(def: (header [class_name type_variables] + super_class + super_interfaces + inheritance + fields + methods) + (-> Declaration + (Type Class) + (List (Type Class)) + Inheritance + (List Field) + (List (Method Code)) + [External Binary]) + (let [constraints (list\map ..constraint type_variables) + field_definitions (list\map ..field_header fields) + method_definitions (list\map (..method_header super_class) methods) + definitions (def.fuse (list\compose field_definitions + method_definitions))] + [class_name + (case inheritance + #ffi.DefaultI + (def.class #jvm.V1_6 #jvm.Public jvm.noneC class_name constraints super_class super_interfaces + definitions) + + #ffi.FinalI + (def.class #jvm.V1_6 #jvm.Public jvm.finalC class_name constraints super_class super_interfaces + definitions) + + #ffi.AbstractI + (def.abstract #jvm.V1_6 #jvm.Public jvm.noneC class_name constraints super_class super_interfaces + definitions))])) + +(def: (constructor_method_analysis archive [class_name class_tvars] method) + (-> Archive Declaration (Constructor Code) (Operation (Constructor Analysis))) + (do {! phase.monad} + [#let [[privacy strict_floating_point? annotations method_tvars exceptions + self arguments constructor_argumentsC + bodyC] method] + analyse directive.analysis] + (directive.lift_analysis + (do ! + [mapping (//A.with_fresh_type_vars class_tvars luxT.fresh) + mapping (//A.with_fresh_type_vars method_tvars mapping) + constructor_argumentsA (monad.map ! (function (_ [typeJ termC]) + (do ! + [typeL (//A.reflection_type mapping typeJ) + termA (typeA.with_type typeL + (analyse archive termC))] + (wrap [typeJ termA]))) + constructor_argumentsC) + selfT (//A.reflection_type mapping (/type.class class_name class_tvars)) + arguments' (monad.map ! + (function (_ [name type]) + (\ ! map (|>> [name]) + (//A.reflection_type mapping type))) + arguments) + returnT (//A.reflection_return mapping /type.void) + [_scope bodyA] (|> arguments' + (#.Cons [self selfT]) + list.reverse + (list\fold scopeA.with_local (analyse archive bodyC)) + (typeA.with_type returnT) + analysis.with_scope)] + (wrap [privacy strict_floating_point? annotations method_tvars exceptions + self arguments constructor_argumentsA + bodyA]))))) + +(def: (override_method_analysis archive [class_name class_tvars] supers method) + (-> Archive Declaration (List (Type Class)) (Override Code) (Operation (Override Analysis))) + (do {! phase.monad} + [#let [[[super_name super_tvars] method_name strict_floating_point? annotations + method_tvars self arguments returnJ exceptionsJ + bodyC] method] + analyse directive.analysis] + (directive.lift_analysis + (do ! + [mapping (//A.with_fresh_type_vars class_tvars luxT.fresh) + #let [parent_type (/type.class super_name super_tvars)] + mapping (//A.with_override_mapping supers parent_type mapping) + mapping (//A.with_fresh_type_vars method_tvars mapping) + selfT (//A.reflection_type mapping (/type.class class_name class_tvars)) + arguments' (monad.map ! + (function (_ [name type]) + (\ ! map (|>> [name]) + (//A.reflection_type mapping type))) + arguments) + returnT (//A.reflection_return mapping returnJ) + [_scope bodyA] (|> arguments' + (#.Cons [self selfT]) + list.reverse + (list\fold scopeA.with_local (analyse archive bodyC)) + (typeA.with_type returnT) + analysis.with_scope)] + (wrap [[super_name super_tvars] method_name strict_floating_point? annotations + method_tvars self arguments returnJ exceptionsJ + bodyA]))))) + +(def: (virtual_method_analysis archive [class_name class_tvars] method) + (-> Archive Declaration (Virtual Code) (Operation (Virtual Analysis))) + (do {! phase.monad} + [#let [[name privacy final? strict_floating_point? annotations method_tvars + self arguments returnJ exceptionsJ + bodyC] method] + analyse directive.analysis] + (directive.lift_analysis + (do ! + [mapping (//A.with_fresh_type_vars class_tvars luxT.fresh) + mapping (//A.with_fresh_type_vars method_tvars mapping) + selfT (//A.reflection_type mapping (/type.class class_name class_tvars)) + arguments' (monad.map ! + (function (_ [name type]) + (\ ! map (|>> [name]) + (//A.reflection_type mapping type))) + arguments) + returnT (//A.reflection_return mapping returnJ) + [_scope bodyA] (|> arguments' + (#.Cons [self selfT]) + list.reverse + (list\fold scopeA.with_local (analyse archive bodyC)) + (typeA.with_type returnT) + analysis.with_scope)] + (wrap [name privacy final? strict_floating_point? annotations method_tvars + self arguments returnJ exceptionsJ + bodyA]))))) + +(def: (static_method_analysis archive method) + (-> Archive (Static Code) (Operation (Static Analysis))) + (do {! phase.monad} + [#let [[name privacy strict_floating_point? annotations method_tvars + arguments returnJ exceptionsJ + bodyC] method] + analyse directive.analysis] + (directive.lift_analysis + (do ! + [mapping (//A.with_fresh_type_vars method_tvars luxT.fresh) + arguments' (monad.map ! + (function (_ [name type]) + (\ ! map (|>> [name]) + (//A.reflection_type mapping type))) + arguments) + returnT (//A.reflection_return mapping returnJ) + [_scope bodyA] (|> arguments' + list.reverse + (list\fold scopeA.with_local (analyse archive bodyC)) + (typeA.with_type returnT) + analysis.with_scope)] + (wrap [name privacy strict_floating_point? annotations method_tvars + arguments returnJ exceptionsJ + bodyA]))))) + +(def: (method_analysis archive declaration supers method) + (-> Archive Declaration (List (Type Class)) (Method Code) (Operation (Method Analysis))) + (case method + (#Constructor method) + (\ phase.monad map (|>> #Constructor) + (constructor_method_analysis archive declaration method)) + + (#Override method) + (\ phase.monad map (|>> #Override) + (override_method_analysis archive declaration supers method)) + + (#Virtual method) + (\ phase.monad map (|>> #Virtual) + (virtual_method_analysis archive declaration method)) + + (#Static method) + (\ phase.monad map (|>> #Static) + (static_method_analysis archive method)) + + (#Abstract method) + (\ phase.monad wrap (#Abstract method)) + )) + +(template: (method_body <bodyS>) + (<| synthesis.function/abstraction [_ _] + synthesis.loop/scope [_ _] + synthesis.tuple + (list _) + <bodyS>)) + +(def: (constructor_method_synthesis archive method) + (-> Archive (Constructor Analysis) (Operation (Constructor Synthesis))) + (do {! phase.monad} + [#let [[privacy strict_floating_point? annotations method_tvars exceptions + self arguments constructor_argumentsA + bodyA] method] + synthesise directive.synthesis] + (directive.lift_synthesis + (do ! + [constructor_argumentsS (monad.map ! (function (_ [typeJ termA]) + (\ ! map (|>> [typeJ]) + (synthesise archive termA))) + constructor_argumentsA) + bodyS (synthesise archive + (list\fold (function (_ _) + (|>> (#analysis.Function (list)))) + (analysis.tuple (list (analysis.unit) bodyA)) + (list.repeat (|> arguments list.size (nat.max 1)) [])))] + (wrap [privacy strict_floating_point? annotations method_tvars exceptions + self arguments constructor_argumentsS + (case bodyS + (^ (method_body bodyS)) + bodyS + + _ + bodyS)]))))) + +(def: (override_method_synthesis archive method) + (-> Archive (Override Analysis) (Operation (Override Synthesis))) + (do {! phase.monad} + [#let [[[super_name super_tvars] method_name strict_floating_point? annotations + method_tvars self arguments returnJ exceptionsJ + bodyA] method] + synthesise directive.synthesis] + (directive.lift_synthesis + (do ! + [bodyS (synthesise archive + (list\fold (function (_ _) + (|>> (#analysis.Function (list)))) + (analysis.tuple (list (analysis.unit) bodyA)) + (list.repeat (|> arguments list.size (nat.max 1)) [])))] + (wrap [[super_name super_tvars] method_name strict_floating_point? annotations + method_tvars self arguments returnJ exceptionsJ + (case bodyS + (^ (method_body bodyS)) + bodyS + + _ + bodyS)]))))) + +(def: (virtual_method_synthesis archive method) + (-> Archive (Virtual Analysis) (Operation (Virtual Synthesis))) + (do {! phase.monad} + [#let [[name privacy final? strict_floating_point? annotations method_tvars + self arguments returnJ exceptionsJ + bodyA] method] + synthesise directive.synthesis] + (directive.lift_synthesis + (do ! + [bodyS (synthesise archive + (list\fold (function (_ _) + (|>> (#analysis.Function (list)))) + (analysis.tuple (list (analysis.unit) bodyA)) + (list.repeat (|> arguments list.size (nat.max 1)) [])))] + (wrap [name privacy final? strict_floating_point? annotations method_tvars + self arguments returnJ exceptionsJ + (case bodyS + (^ (method_body bodyS)) + bodyS + + _ + bodyS)]))))) + +(def: (static_method_synthesis archive method) + (-> Archive (Static Analysis) (Operation (Static Synthesis))) + (do {! phase.monad} + [#let [[name privacy strict_floating_point? annotations method_tvars + arguments returnJ exceptionsJ + bodyA] method] + synthesise directive.synthesis] + (directive.lift_synthesis + (do ! + [bodyS (synthesise archive + (list\fold (function (_ _) + (|>> (#analysis.Function (list)))) + (analysis.tuple (list (analysis.unit) bodyA)) + (list.repeat (|> arguments list.size (nat.max 1)) [])))] + (wrap [name privacy strict_floating_point? annotations method_tvars + arguments returnJ exceptionsJ + (case bodyS + (^ (method_body bodyS)) + bodyS + + _ + bodyS)]))))) + +(def: (method_synthesis archive method) + (-> Archive (Method Analysis) (Operation (Method Synthesis))) + (case method + (#Constructor method) + (\ phase.monad map (|>> #Constructor) + (constructor_method_synthesis archive method)) + + (#Override method) + (\ phase.monad map (|>> #Override) + (override_method_synthesis archive method)) + + (#Virtual method) + (\ phase.monad map (|>> #Virtual) + (virtual_method_synthesis archive method)) + + (#Static method) + (\ phase.monad map (|>> #Static) + (static_method_synthesis archive method)) + + (#Abstract method) + (\ phase.monad wrap (#Abstract method)) + )) + +(def: (constructor_method_generation archive super_class method) + (-> Archive (Type Class) (Constructor Synthesis) (Operation jvm.Def)) + (do {! phase.monad} + [#let [[privacy strict_floating_point? annotations method_tvars exceptions + self arguments constructor_argumentsS + bodyS] method] + generate directive.generation] + (directive.lift_generation + (do ! + [constructor_argumentsG (monad.map ! (|>> product.right (generate archive)) + constructor_argumentsS) + bodyG (generate archive bodyS) + #let [[super_name super_vars] (parser.read_class super_class) + super_constructor_argument_values (_.fuse constructor_argumentsG) + super_constructorT (/type.method [(list) + (list\map product.left constructor_argumentsS) + /type.void + (list)])]] + (wrap (def.method (..visibility privacy) + (if strict_floating_point? + jvm.strictM + jvm.noneM) + ..constructor_name + (/type.method [method_tvars (list\map product.right arguments) /type.void exceptions]) + (|>> (_.ALOAD 0) + super_constructor_argument_values + (_.INVOKESPECIAL super_class ..constructor_name super_constructorT) + bodyG + _.RETURN))))))) + +(def: (override_method_generation archive method) + (-> Archive (Override Synthesis) (Operation jvm.Def)) + (do {! phase.monad} + [#let [[[super_name super_tvars] method_name strict_floating_point? annotations + method_tvars self arguments returnJ exceptionsJ + bodyS] method] + generate directive.generation] + (directive.lift_generation + (do ! + [bodyG (generate archive bodyS)] + (wrap (def.method #jvm.Public + (if strict_floating_point? + jvm.strictM + jvm.noneM) + method_name + (/type.method [method_tvars (list\map product.right arguments) returnJ exceptionsJ]) + (|>> bodyG + (//G.returnI returnJ)))))))) + +(def: (virtual_method_generation archive method) + (-> Archive (Virtual Synthesis) (Operation jvm.Def)) + (do {! phase.monad} + [#let [[method_name privacy final? strict_floating_point? annotations method_tvars + self arguments returnJ exceptionsJ + bodyS] method] + generate directive.generation] + (directive.lift_generation + (do ! + [bodyG (generate archive bodyS)] + (wrap (def.method (..visibility privacy) + (|> jvm.noneM + (jvm.++M (if strict_floating_point? + jvm.strictM + jvm.noneM)) + (jvm.++M (if final? + jvm.finalM + jvm.noneM))) + method_name + (/type.method [method_tvars (list\map product.right arguments) returnJ exceptionsJ]) + (|>> bodyG + (//G.returnI returnJ)))))))) + +(def: (static_method_generation archive method) + (-> Archive (Static Synthesis) (Operation jvm.Def)) + (do {! phase.monad} + [#let [[method_name privacy strict_floating_point? annotations method_tvars + arguments returnJ exceptionsJ + bodyS] method] + generate directive.generation] + (directive.lift_generation + (do ! + [bodyG (generate archive bodyS)] + (wrap (def.method (..visibility privacy) + (|> jvm.staticM + (jvm.++M (if strict_floating_point? + jvm.strictM + jvm.noneM))) + method_name + (/type.method [method_tvars (list\map product.right arguments) returnJ exceptionsJ]) + (|>> bodyG + (//G.returnI returnJ)))))))) + +(def: (method_generation archive super_class method) + (-> Archive (Type Class) (Method Synthesis) (Operation jvm.Def)) + (case method + (#Constructor method) + (..constructor_method_generation archive super_class method) + + (#Override method) + (..override_method_generation archive method) + + (#Virtual method) + (..virtual_method_generation archive method) + + (#Static method) + (..static_method_generation archive method) + + (#Abstract method) + (\ phase.monad wrap (..abstract_method_generation method)) + )) + +(def: jvm::class + ..Handler + (..custom + [($_ <>.and + ..class_declaration + ..class + (<code>.tuple (<>.some ..class)) + ..inheritance + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..field)) + (<code>.tuple (<>.some ..method))) + (function (_ extension_name phase archive + [declaration + super_class + super_interfaces + inheritance + annotations + fields + methodsC]) + (do {! phase.monad} + [#let [[class_name type_variables] declaration + header (..header [class_name type_variables] + super_class + super_interfaces + inheritance + fields + methodsC)] + ## Necessary for reflection to work properly during analysis. + _ (directive.lift_generation + (generation.execute! header)) + #let [supers (: (List (Type Class)) + (list& super_class super_interfaces))] + methodsA (monad.map ! (method_analysis archive declaration supers) methodsC) + methodsS (monad.map ! (method_synthesis archive) methodsA) + methodsG (monad.map ! (method_generation archive super_class) methodsS) + #let [directive [class_name + (def.class #jvm.V1_6 #jvm.Public jvm.noneC class_name + (list\map ..constraint type_variables) + super_class + super_interfaces + (def.fuse (list\compose (list\map ..field_header fields) + methodsG)))]]] + (directive.lift_generation + (do ! + [artifact_id (generation.learn_custom class_name) + _ (generation.execute! directive) + _ (generation.save! artifact_id (#.Some class_name) directive) + _ (generation.log! (format "JVM Class " (%.text class_name)))] + (wrap directive.no_requirements)))))])) + (def: jvm::class::interface ..Handler (..custom @@ -630,14 +1442,9 @@ (<>.some ..method_declaration)) (function (_ extension_name phase archive [[class_name type_variables] supers annotations method_declarations]) (do {! phase.monad} - [#let [constraints (list\map (function (_ tv) - {#/type.name (parser.name tv) - #/type.super_class java/lang/Object - #/type.super_interfaces (list)}) - type_variables) - directive [class_name + [#let [directive [class_name (def.interface #jvm.V1_6 #jvm.Public jvm.noneC class_name - constraints + (list\map ..constraint type_variables) supers (|> method_declarations (list\map (function (_ (^slots [#name #annotations #type_variables #exceptions #arguments #return])) @@ -656,4 +1463,5 @@ (-> jvm.Extender (directive.Bundle jvm.Anchor jvm.Inst jvm.Definition)) (|> bundle.empty (dictionary.put "lux def generation" (..def::generation extender)) + (dictionary.put "jvm class" ..jvm::class) (dictionary.put "jvm class interface" ..jvm::class::interface))) |