aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/directive
diff options
context:
space:
mode:
authorEduardo Julian2019-09-07 20:02:14 -0400
committerEduardo Julian2019-09-07 20:02:14 -0400
commit5f494b497e79bcea1d3c64d663ca5435bbf8ca2d (patch)
tree2a7ac78ae896042039e1311a14948026cbe66585 /new-luxc/source/luxc/lang/directive
parent747abe180b2669b6af5779dcf39ab5a8b6ed11ed (diff)
Renamed "Statement" to "Directive".
Diffstat (limited to 'new-luxc/source/luxc/lang/directive')
-rw-r--r--new-luxc/source/luxc/lang/directive/jvm.lux263
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)
+ )))