From a6ad4391394f37fb8a729a26e27826c17a477fec Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 9 May 2019 20:43:13 -0400 Subject: WIP: Anonymous classes analysis & generation. --- .../luxc/lang/translation/jvm/procedure/host.lux | 258 ++++++++++++++++++--- 1 file changed, 231 insertions(+), 27 deletions(-) (limited to 'new-luxc/source/luxc/lang/translation/jvm') 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) + ["" text] + ["" 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 [] [(exception: #export ( {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 "["))) + (.Parser Type) + ($_ <>.either + (<>.after (.this "boolean") (<>@wrap _t.boolean)) + (<>.after (.this "byte") (<>@wrap _t.byte)) + (<>.after (.this "short") (<>@wrap _t.short)) + (<>.after (.this "int") (<>@wrap _t.int)) + (<>.after (.this "long") (<>@wrap _t.long)) + (<>.after (.this "float") (<>@wrap _t.float)) + (<>.after (.this "double") (<>@wrap _t.double)) + (<>.after (.this "char") (<>@wrap _t.char)) + (<>@map (function (_ name) + (_t.class name (list))) + (.many (.none-of "["))) )) (def: java-type - (l.Parser Type) - (do p.monad + (.Parser Type) + (do <>.monad [raw base-type - nesting (p.some (l.this "[]"))] + nesting (<>.some (.this "[]"))] (wrap (_t.array (list.size nesting) raw)))) (def: (generate-type argD) (-> Text (Operation Type)) - (case (l.run argD java-type) + (case (.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] + (-> [(.Parser s) + (-> Text Phase s (Operation Inst))] + Handler)) + (function (_ extension-name phase input) + (case (.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 + (.Parser /.JVM-Type) + (<>.rec + (function (_ jvm-type) + (.tuple (<>.and .text (<>.some jvm-type)))))) + +(def: constructor-arg + (.Parser (/.Constructor-Argument Synthesis)) + (.tuple (<>.and ..jvm-type .any))) + +(def: annotation-parameter + (.Parser (/.Annotation-Parameter Synthesis)) + (.tuple (<>.and .text .any))) + +(def: annotation + (.Parser (/.Annotation Synthesis)) + (.tuple (<>.and .text (<>.some ..annotation-parameter)))) + +(def: type-parameter + (.Parser /.Type-Parameter) + .text) + +(def: argument + (.Parser /.Argument) + (.tuple (<>.and .text ..jvm-type))) + +(def: overriden-method-definition + (.Parser [Environment (/.Overriden-Method Synthesis)]) + (.tuple (do <>.monad + [ownerT ..jvm-type + name .text + strict-fp? .bit + annotations (.tuple (<>.some ..annotation)) + type-parameters (.tuple (<>.some ..type-parameter)) + self-name .text + arguments (.tuple (<>.some ..argument)) + returnT ..jvm-type + exceptionsT (.tuple (<>.some ..jvm-type)) + [environment body] (.function 1 + (.tuple .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 [] + (^ ( leftP rightP)) + ( (recur leftP) (recur rightP))) + ([#synthesis.Alt] + [#synthesis.Seq]) + + (^template [] + (^ ( 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 [] + (^ ( 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 + .text + ..jvm-type + (.tuple (<>.some ..jvm-type)) + (.tuple (<>.some ..constructor-arg)) + (.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) ))) -- cgit v1.2.3