diff options
Diffstat (limited to 'stdlib/source/lux/tool/compiler/phase/extension/directive/jvm.lux')
-rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/directive/jvm.lux | 303 |
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) + ))) |