diff options
Diffstat (limited to 'new-luxc')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux | 258 |
1 files changed, 231 insertions, 27 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux index d3fea1152..dfcbd8f84 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -3,35 +3,45 @@ [abstract ["." monad (#+ do)]] [control - ["ex" exception (#+ exception:)] - ["p" parser ("#@." monad) - ["l" text]]] + ["." exception (#+ exception:)] + ["<>" parser ("#@." monad) + ["<t>" text] + ["<s>" synthesis]]] [data ["." product] + ["." maybe] ["." error] + [number + ["." nat]] ["." text format] [collection - ["." list ("#@." functor)] - ["." dictionary (#+ Dictionary)]]] + ["." list ("#@." monad)] + ["." dictionary (#+ Dictionary)] + ["." set]]] [target [jvm ["_t" type (#+ Primitive Type Method)]]] [tool [compiler - ["." synthesis (#+ Synthesis %synthesis)] + [analysis (#+ Environment)] + ["." reference (#+ Variable)] + ["." synthesis (#+ Synthesis Path %synthesis)] ["." phase ("#@." monad) - [generation + ["." generation [extension (#+ Nullary Unary Binary nullary unary binary)]] ["." extension - ["." bundle]]]]] + ["." bundle] + [analysis + ["/" jvm]]]]]] [host (#+ import:)]] [luxc [lang [host - ["$" jvm (#+ Label Inst Handler Bundle Operation) - ["_" inst]]]]]) + ["$" jvm (#+ Label Inst Handler Bundle Operation Phase) + ["_" inst] + ["_." def]]]]]) (template [<name>] [(exception: #export (<name> {message Text}) @@ -662,31 +672,31 @@ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) (def: base-type - (l.Parser Type) - ($_ p.either - (p.after (l.this "boolean") (p@wrap _t.boolean)) - (p.after (l.this "byte") (p@wrap _t.byte)) - (p.after (l.this "short") (p@wrap _t.short)) - (p.after (l.this "int") (p@wrap _t.int)) - (p.after (l.this "long") (p@wrap _t.long)) - (p.after (l.this "float") (p@wrap _t.float)) - (p.after (l.this "double") (p@wrap _t.double)) - (p.after (l.this "char") (p@wrap _t.char)) - (p@map (function (_ name) - (_t.class name (list))) - (l.many (l.none-of "["))) + (<t>.Parser Type) + ($_ <>.either + (<>.after (<t>.this "boolean") (<>@wrap _t.boolean)) + (<>.after (<t>.this "byte") (<>@wrap _t.byte)) + (<>.after (<t>.this "short") (<>@wrap _t.short)) + (<>.after (<t>.this "int") (<>@wrap _t.int)) + (<>.after (<t>.this "long") (<>@wrap _t.long)) + (<>.after (<t>.this "float") (<>@wrap _t.float)) + (<>.after (<t>.this "double") (<>@wrap _t.double)) + (<>.after (<t>.this "char") (<>@wrap _t.char)) + (<>@map (function (_ name) + (_t.class name (list))) + (<t>.many (<t>.none-of "["))) )) (def: java-type - (l.Parser Type) - (do p.monad + (<t>.Parser Type) + (do <>.monad [raw base-type - nesting (p.some (l.this "[]"))] + nesting (<>.some (<t>.this "[]"))] (wrap (_t.array (list.size nesting) raw)))) (def: (generate-type argD) (-> Text (Operation Type)) - (case (l.run argD java-type) + (case (<t>.run argD java-type) (#error.Failure error) (phase.throw invalid-syntax-for-jvm-type argD) @@ -808,6 +818,199 @@ (bundle.install "constructor" invoke::constructor)))) ))) +(def: (custom [parser handler]) + (All [s] + (-> [(<s>.Parser s) + (-> Text Phase s (Operation Inst))] + Handler)) + (function (_ extension-name phase input) + (case (<s>.run input parser) + (#error.Success input') + (handler extension-name phase input') + + (#error.Failure error) + (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) + +(def: jvm-type + (<s>.Parser /.JVM-Type) + (<>.rec + (function (_ jvm-type) + (<s>.tuple (<>.and <s>.text (<>.some jvm-type)))))) + +(def: constructor-arg + (<s>.Parser (/.Constructor-Argument Synthesis)) + (<s>.tuple (<>.and ..jvm-type <s>.any))) + +(def: annotation-parameter + (<s>.Parser (/.Annotation-Parameter Synthesis)) + (<s>.tuple (<>.and <s>.text <s>.any))) + +(def: annotation + (<s>.Parser (/.Annotation Synthesis)) + (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter)))) + +(def: type-parameter + (<s>.Parser /.Type-Parameter) + <s>.text) + +(def: argument + (<s>.Parser /.Argument) + (<s>.tuple (<>.and <s>.text ..jvm-type))) + +(def: overriden-method-definition + (<s>.Parser [Environment (/.Overriden-Method Synthesis)]) + (<s>.tuple (do <>.monad + [ownerT ..jvm-type + name <s>.text + strict-fp? <s>.bit + annotations (<s>.tuple (<>.some ..annotation)) + type-parameters (<s>.tuple (<>.some ..type-parameter)) + self-name <s>.text + arguments (<s>.tuple (<>.some ..argument)) + returnT ..jvm-type + exceptionsT (<s>.tuple (<>.some ..jvm-type)) + [environment body] (<s>.function 1 + (<s>.tuple <s>.any))] + (wrap [environment + [ownerT name + strict-fp? annotations type-parameters + self-name arguments returnT exceptionsT + body]])))) + +(def: (normalize-path normalize) + (-> (-> Synthesis Synthesis) + (-> Path Path)) + (function (recur path) + (case path + (^ (synthesis.path/then bodyS)) + (synthesis.path/then (normalize bodyS)) + + (^template [<tag>] + (^ (<tag> leftP rightP)) + (<tag> (recur leftP) (recur rightP))) + ([#synthesis.Alt] + [#synthesis.Seq]) + + (^template [<tag>] + (^ (<tag> value)) + path) + ([#synthesis.Pop] + [#synthesis.Test] + [#synthesis.Bind] + [#synthesis.Access])))) + +(def: (normalize-method-body mapping) + (-> (Dictionary Variable Variable) Synthesis Synthesis) + (function (recur body) + (case body + (^template [<tag>] + (^ (<tag> value)) + body) + ([#synthesis.Primitive] + [synthesis.constant]) + + (^ (synthesis.variant [lefts right? sub])) + (synthesis.variant [lefts right? (recur sub)]) + + (^ (synthesis.tuple members)) + (synthesis.tuple (list@map recur members)) + + (^ (synthesis.variable var)) + (|> mapping + (dictionary.get var) + (maybe.default var) + synthesis.variable) + + (^ (synthesis.branch/case [inputS pathS])) + (synthesis.branch/case [(recur inputS) (normalize-path recur pathS)]) + + (^ (synthesis.branch/let [inputS register outputS])) + (synthesis.branch/let [(recur inputS) register (recur outputS)]) + + (^ (synthesis.branch/if [testS thenS elseS])) + (synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) + + (^ (synthesis.loop/scope [offset initsS+ bodyS])) + (synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)]) + + (^ (synthesis.loop/recur updatesS+)) + (synthesis.loop/recur (list@map recur updatesS+)) + + (^ (synthesis.function/abstraction [environment arity bodyS])) + (synthesis.function/abstraction [(|> environment (list@map (function (_ local) + (|> mapping + (dictionary.get local) + (maybe.default local))))) + arity + bodyS]) + + (^ (synthesis.function/apply [functionS inputsS+])) + (synthesis.function/apply [(recur functionS) (list@map recur inputsS+)]) + + (#synthesis.Extension [name inputsS+]) + (#synthesis.Extension [name (list@map recur inputsS+)])))) + +(def: class::anonymous + Handler + (..custom + [($_ <>.and + <s>.text + ..jvm-type + (<s>.tuple (<>.some ..jvm-type)) + (<s>.tuple (<>.some ..constructor-arg)) + (<s>.tuple (<>.some ..overriden-method-definition))) + (function (_ extension-name generate [class-name + super-class super-interfaces + constructor-args + overriden-methods]) + (do phase.monad + [#let [global-mapping (|> overriden-methods + ## Get all the environments. + (list@map product.left) + ## Combine them. + list@join + ## Remove duplicates. + (set.from-list reference.hash) + set.to-list + ## Give them names as "foreign" variables. + list.enumerate + (list@map (function (_ [id capture]) + [capture (#reference.Foreign id)])) + (dictionary.from-list reference.hash)) + normalized-methods (list@map (function (_ [environment + [ownerT name + strict-fp? annotations type-parameters + self-name arguments returnT exceptionsT + body]]) + (let [local-mapping (|> environment + list.enumerate + (list@map (function (_ [foreign-id capture]) + [(#reference.Foreign foreign-id) + (|> global-mapping + (dictionary.get capture) + maybe.assume)])) + (dictionary.from-list reference.hash))] + [ownerT name + strict-fp? annotations type-parameters + self-name arguments returnT exceptionsT + (normalize-method-body local-mapping body)])) + overriden-methods)] + ## _ (generation.save! true ["" function-class] + ## [function-class + ## (def.class #$.V1_6 #$.Public $.finalC + ## function-class (list) + ## ($.simple-class //.function-class) (list) + ## functionD)]) + _ (phase.throw extension.invalid-syntax ["YOLO-TRON" %synthesis (list)])] + (wrap _.DUP)))])) + +(def: class + Bundle + (<| (bundle.prefix "class") + (|> (: Bundle bundle.empty) + (bundle.install "anonymous" class::anonymous) + ))) + (def: #export bundle Bundle (<| (bundle.prefix "jvm") @@ -820,4 +1023,5 @@ (dictionary.merge ..array) (dictionary.merge ..object) (dictionary.merge ..member) + (dictionary.merge ..class) ))) |