diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/directive')
| -rw-r--r-- | new-luxc/source/luxc/lang/directive/jvm.lux | 263 |
1 files changed, 263 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/directive/jvm.lux b/new-luxc/source/luxc/lang/directive/jvm.lux new file mode 100644 index 000000000..5c1ddee0d --- /dev/null +++ b/new-luxc/source/luxc/lang/directive/jvm.lux @@ -0,0 +1,263 @@ +(.module: + [lux (#- Type Definition) + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)] + ["<t>" text]]] + [data + ["." product] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#@." functor fold)] + ["." dictionary]]] + [type + ["." check (#+ Check)]] + [target + [jvm + ["." type (#+ Type Constraint Argument Typed) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] + [".T" lux] + ["." signature] + ["." descriptor (#+ Descriptor)] + ["." parser]]]] + [tool + [compiler + ["." directive (#+ Handler Bundle)] + ["." phase + ["." generation] + [analysis + [".A" type]] + ["." extension + ["." bundle] + [analysis + ["." jvm]] + [directive + ["/" lux]]]]]]] + [luxc + [lang + [host + ["$" jvm (#+ Anchor Inst Definition Operation Phase) + ["_." def]]]]]) + +(def: signature (|>> type.signature signature.signature)) + +(type: Declaration + [Text (List (Type Var))]) + +(def: declaration + (Parser Declaration) + (<c>.form (<>.and <c>.text (<>.some jvm.var)))) + +(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) + +(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 jvm.Visibility State (List Annotation) (Type Value)]) + +(def: variable + (Parser Variable) + (<| <c>.form + (<>.after (<c>.text! "variable")) + ($_ <>.and + <c>.text + jvm.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: 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 (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) + field-definitions (|> fields + (list@map (function (_ field) + (case field + ## TODO: Handle annotations. + (#Constant [name annotations type value]) + (case value + (^template [<tag> <field>] + [_ (<tag> value)] + (<field> #$.Public ($.++F $.staticF $.finalF) name value)) + ([#.Bit _def.boolean-field] + [#.Int _def.byte-field] + [#.Int _def.short-field] + [#.Int _def.int-field] + [#.Int _def.long-field] + [#.Frac _def.float-field] + [#.Frac _def.double-field] + [#.Nat _def.char-field] + [#.Text _def.string-field]) + + _ + (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 (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 @ (function (_ methodC) + (do @ + [methodA (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)))) + methods) + _ (directive.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 parser.name ..constraint) parameters) + super-class super-interfaces + field-definitions)])) + #let [_ (log! (format "Class " name))]] + (wrap directive.no-requirements)))])) + +(def: #export bundle + (Bundle Anchor Inst Definition) + (<| (bundle.prefix "jvm") + (|> bundle.empty + (dictionary.put "class" jvm::class) + ))) |